1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34lefts u == 35 [x for x in HKEYS $has_category_hash | rest x = u] 36 37 38--============================================================================ 39-- Build Library Database (libdb.text,...) 40--============================================================================ 41--Format for libdb.text: 42-- constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) 43-- operations Op \#\E\sig \conname\pred\comments (E is one of U/E) 44-- I = <x if exposed><d if category with a default package> 45buildLibdb(domainList) == --called by make-databases (daase.lisp) 46 $OpLst: local := nil 47 $AttrLst: local := nil 48 $DomLst : local := nil 49 $CatLst : local := nil 50 $PakLst : local := nil 51 $DefLst : local := nil 52 $outStream : local := MAKE_OUTSTREAM('"temp.text") 53 --build local libdb if list of domains is given 54 if null domainList then 55 comments := 56 '"\spad{Union(A,B,...,C)} is a primitive type in FriCAS used to represent objects of type \spad{A} or of type \spad{B} or...or of type \spad{C}." 57 writedb 58 buildLibdbString ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'UNION,comments] 59 comments := 60 '"\spad{Record(a:A,b:B,...,c:C)} is a primitive type in FriCAS 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}." 61 writedb 62 buildLibdbString ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments] 63 comments := 64 '"\spad{Mapping(T,S)} is a primitive type in FriCAS 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}." 65 writedb 66 buildLibdbString ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments] 67 comments := 68 '"\spad{Enumeration(a,b,...,c)} is a primitive type in FriCAS used to represent the object composed of the symbols \spad{a},\spad{b},..., and \spad{c}." 69 writedb 70 buildLibdbString ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments] 71 $conname: local := nil 72 $conform: local := nil 73 $exposed?:local := nil 74 $doc: local := nil 75 $kind: local := nil 76 constructorList := domainList or allConstructors() 77 for con in constructorList repeat 78 writedb buildLibdbConEntry con 79 [., :oplist] := getConstructorExports($conform, false) 80 buildLibOps oplist 81 SHUT $outStream 82 domainList => 'done --leave new database in temp.text 83 OBEY '"sort _"temp.text_" > _"libdb.text_"" 84 RENAME_-FILE('"libdb.text", '"olibdb.text") 85 deleteFile '"temp.text" 86 87buildLibdbConEntry conname == 88 NULL GETDATABASE(conname, 'CONSTRUCTORMODEMAP) => nil 89 abb:=GETDATABASE(conname,'ABBREVIATION) 90 $conname := conname 91 conform := GETDATABASE(conname,'CONSTRUCTORFORM) or [conname] --hack for Category,.. 92 $conform := dbMkForm SUBST('T,"T$",conform) 93 null $conform => nil 94 $exposed? := (isExposedConstructor conname => '"x"; '"n") 95 $doc := GETDATABASE(conname, 'DOCUMENTATION) 96 pname := PNAME conname 97 kind := GETDATABASE(conname,'CONSTRUCTORKIND) 98 if kind = 'domain 99 and GETDATABASE(conname,'CONSTRUCTORMODEMAP) is [[.,t,:.],:.] 100 and t is ['CATEGORY,'package,:.] then kind := 'package 101 $kind := 102 pname.(MAXINDEX pname) = char '_& => 'x 103 DOWNCASE (PNAME kind).0 104 argl := rest $conform 105 conComments := 106 LASSOC('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r 107 '"" 108 argpart:= SUBSTRING(form2HtString ['f,:argl],1,nil) 109 sigpart:= libConstructorSig $conform 110 header := STRCONC($kind,PNAME conname) 111 buildLibdbString [header,#argl,$exposed?,sigpart,argpart,abb,conComments] 112 113dbMkForm x == atom x and [x] or x 114 115buildLibdbString [x,:u] == 116 STRCONC(STRINGIMAGE x,"STRCONC"/[STRCONC('"`",STRINGIMAGE y) for y in u]) 117 118libConstructorSig [conname,:argl] == 119 [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP) 120 formals := TAKE(#argl,$FormalMapVariableList) 121 sig := SUBLISLIS(formals,$TriangleVariableList,sig) 122 keys := [g(f,sig,i) for f in formals for i in 1..] where 123 g(x,u,i) == --does x appear in any but i-th element of u? 124 or/[CONTAINED(x,y) for y in u for j in 1.. | j ~= i] 125 sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where 126 fn x == 127 atom x => x 128 x is ['Join,a,:r] => ['Join,fn a,'etc] 129 x is ['CATEGORY,:.] => 'etc 130 [fn y for y in x] 131 sig := [first sig,:[(k => [":",a,s]; s) 132 for a in argl for s in rest sig for k in keys]] 133 sigpart:= form2LispString ['Mapping,:sig] 134 if null ncParseFromString sigpart then 135 sayBrightly ['"Won't parse: ",sigpart] 136 sigpart 137 138concatWithBlanks r == 139 r is [head,:tail] => 140 tail => STRCONC(head,'" ",concatWithBlanks tail) 141 head 142 '"" 143 144writedb(u) == 145 not STRINGP u => nil --skip if not a string 146 PRINTEXP(u, $outStream) 147 TERPRI $outStream 148 149buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred) 150 151buildLibOp(op,sig,pred) == 152--operations OKop \#\sig \conname\pred\comments (K is U or C) 153 nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig) 154 pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) 155 nsig := SUBST('T,"T$",nsig) --this ancient artifact causes troubles! 156 pred := SUBST('T,"T$",pred) 157 sigpart:= form2LispString ['Mapping,:nsig] 158 predString := (pred = 'T => '""; form2LispString pred) 159 sop := 160 (s := STRINGIMAGE op) = '"One" => '"1" 161 s = '"Zero" => '"0" 162 s 163 header := STRCONC('"o",sop) 164 conform:= STRCONC($kind,form2LispString $conform) 165 comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc)) 166 checkCommentsForBraces('operation,sop,sigpart,comments) 167 writedb 168 buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments] 169 170libdbTrim s == 171 k := MAXINDEX s 172 k < 0 => s 173 for i in 0..k repeat 174 s.i = $Newline => SETELT(s,i,char '_ ) 175 trimString s 176 177checkCommentsForBraces(kind,sop,sigpart,comments) == 178 count := 0 179 for i in 0..MAXINDEX comments repeat 180 c := comments.i 181 c = char '_{ => count := count + 1 182 c = char '_} => 183 count := count - 1 184 count < 0 => missingLeft := true 185 if count < 0 or missingLeft then 186 tail := 187 kind = 'attribute => [sop,'"(",sigpart,'")"] 188 [sop,'": ",sigpart] 189 sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail] 190 if count > 0 then 191 sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail] 192 if count ~= 0 or missingLeft then pp comments 193 194dbHasExamplePage conname == 195 sname := STRINGIMAGE conname 196 abb := constructor? conname 197 ucname := UPCASE STRINGIMAGE abb 198 pathname :=STRCONC(getEnv '"FRICAS",'"/share/hypertex/pages/",ucname,'".ht") 199 isExistingFile pathname => INTERN STRCONC(sname,'"XmpPage") 200 nil 201 202dbReadComments(n) == 203 n = 0 => '"" 204 instream := MAKE_INSTREAM(STRCONC(getEnv('"FRICAS"), '"/algebra/comdb.text")) 205 FILE_-POSITION(instream,n) 206 line := read_line instream 207 k := dbTickIndex(line,1,1) 208 line := SUBSTRING(line,k + 1,nil) 209 while not EOFP instream and (x := read_line instream) and 210 (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and 211 x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat 212 xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] 213 SHUT instream 214 STRCONC(line, "STRCONC"/NREVERSE xtralines) 215 216dbSplitLibdb() == 217 instream := MAKE_INSTREAM('"olibdb.text") 218 outstream := MAKE_OUTSTREAM('"libdb.text") 219 comstream := MAKE_OUTSTREAM('"comdb.text") 220 PRINTEXP(0, comstream) 221 PRINTEXP($tick,comstream) 222 PRINTEXP('"", comstream) 223 TERPRI(comstream) 224 while not EOFP instream repeat 225 line := read_line instream 226 outP := FILE_-POSITION outstream 227 comP := FILE_-POSITION comstream 228 [prefix,:comments] := dbSplit(line,6,1) 229 PRINTEXP(prefix,outstream) 230 PRINTEXP($tick ,outstream) 231 null comments => 232 PRINTEXP(0,outstream) 233 TERPRI(outstream) 234 PRINTEXP(comP,outstream) 235 TERPRI(outstream) 236 PRINTEXP(outP ,comstream) 237 PRINTEXP($tick ,comstream) 238 PRINTEXP(first comments,comstream) 239 TERPRI(comstream) 240 for c in rest comments repeat 241 PRINTEXP(outP ,comstream) 242 PRINTEXP($tick ,comstream) 243 PRINTEXP(c, comstream) 244 TERPRI(comstream) 245 SHUT instream 246 SHUT outstream 247 SHUT comstream 248 deleteFile '"olibdb.text" 249 250dbSplit(line,n,k) == 251 k := charPosition($tick,line,k + 1) 252 n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)] 253 dbSplit(line,n - 1,k) 254 255dbSpreadComments(line,n) == 256 line = '"" => nil 257 k := charPosition(char '_-,line,n + 2) 258 k >= MAXINDEX line => [SUBSTRING(line,n,nil)] 259 line.(k + 1) ~= char '_- => 260 u := dbSpreadComments(line,k) 261 [STRCONC(SUBSTRING(line,n,k - n),first u),:rest u] 262 [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)] 263 264--============================================================================ 265-- Build Glossary 266--============================================================================ 267buildGloss() == --called by buildDatabase (database.boot) 268--starting with gloss.text, build glosskey.text and glossdef.text 269 $constructorName : local := nil 270 $exposeFlag : local := true 271 $outStream : local := MAKE_OUTSTREAM('"temp.text") 272 $x : local := nil 273 $attribute? : local := true --do not surround first word 274 pathname := '"gloss.text" 275 instream := MAKE_INSTREAM(pathname) 276 keypath := '"glosskey.text" 277 maybe_delete_file(keypath) 278 outstream := MAKE_OUTSTREAM(keypath) 279 htpath := '"gloss.ht" 280 maybe_delete_file(htpath) 281 htstream := MAKE_OUTSTREAM(htpath) 282 defpath := '"glossdef.text" 283 defstream := MAKE_OUTSTREAM(defpath) 284 pairs := getGlossLines instream 285 PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream) 286 for [name,:line] in pairs repeat 287 outP := FILE_-POSITION outstream 288 defP := FILE_-POSITION defstream 289 lines := spreadGlossText transformAndRecheckComments(name,[line]) 290 PRINTEXP(name, outstream) 291 PRINTEXP($tick,outstream) 292 PRINTEXP(defP, outstream) 293 TERPRI(outstream) 294-- PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream) 295 PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream) 296 PRINTEXP(name, htstream) 297 PRINTEXP('"}\space{}",htstream) 298 TERPRI(htstream) 299 for x in lines repeat 300 PRINTEXP(outP, defstream) 301 PRINTEXP($tick,defstream) 302 PRINTEXP(x, defstream) 303 TERPRI defstream 304 PRINTEXP("STRCONC"/lines,htstream) 305 TERPRI htstream 306 PRINTEXP('"\endmenu\endscroll",htstream) 307 PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream) 308 PRINTEXP('"\end{page}",htstream) 309 SHUT instream 310 SHUT outstream 311 SHUT defstream 312 SHUT htstream 313 SHUT $outStream 314 315spreadGlossText(line) == 316--this function breaks up a line into chunks 317--eventually long line is put into gloss.text as several chunks as follows: 318----- key1`this is the first chunk 319----- XXX`and this is the second 320----- XXX`and this is the third 321----- key2`and this is the fourth 322--where XXX is the file position of key1 323--this is because grepping will only pick up the first 512 characters 324 line = '"" => nil 325 MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))] 326 [line] 327 328getGlossLines instream == 329--instream has text of the form: 330----- key1`this is the first line 331----- and this is the second 332----- key2'and this is the third 333--result is 334----- key1'this is the first line and this is the second 335----- key2'and this is the third 336 keys := nil 337 text := nil 338 lastLineHadTick := false 339 while not EOFP instream repeat 340 line := read_line instream 341 #line = 0 => 'skip 342 n := charPosition($tick,line,0) 343 last := IFCAR text 344 n > MAXINDEX line => --this line is continuation of previous line; concat it 345 fill := 346 #last = 0 => 347 lastLineHadTick => '"" 348 '"\blankline " 349 #last > 0 and last.(MAXINDEX last) ~= $charBlank => $charBlank 350 '"" 351 lastLineHadTick := false 352 text := [STRCONC(last,fill,line),:rest text] 353 lastLineHadTick := true 354 keys := [SUBSTRING(line,0,n),:keys] 355 text := [SUBSTRING(line,n + 1,nil),:text] 356 ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text]) 357 --this complication sorts them after lower casing the keys 358 359--============================================================================ 360-- Build Users HashTable 361-- This database is written out as USERS.DATABASE (database.boot) and read using 362-- function getUsersOfConstructor. See functions whoUses and kcuPage in browser. 363--============================================================================ 364mkUsersHashTable() == --called by make-databases (daase.lisp) 365 $usersTb := MAKE_HASHTABLE('EQUAL) 366 for x in allConstructors() repeat 367 for conform in getImports x repeat 368 name := opOf conform 369 if not MEMQ(name,'(QUOTE)) then 370 HPUT($usersTb,name,insert(x,HGET($usersTb,name))) 371 for k in HKEYS $usersTb repeat 372 HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k))) 373 for x in allConstructors() | isDefaultPackageName x repeat 374 HPUT($usersTb,x,getDefaultPackageClients x) 375 $usersTb 376 377getDefaultPackageClients con == --called by mkUsersHashTable 378 catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s) 379 for [catAncestor,:.] in childrenOf([catname]) repeat 380 pakname := INTERN STRCONC(PNAME catAncestor,'"&") 381 if getCDTEntry(pakname,true) then acc := [pakname,:acc] 382 acc := union([CAAR x for x in domainsOf([catAncestor],nil)],acc) 383 listSort(function GLESSEQP,acc) 384 385--============================================================================ 386-- Build Dependents Hashtable 387-- This hashtable is written out by database.boot as DEPENDENTS.DATABASE 388-- and read back in by getDependentsOfConstructor (see database.boot) 389-- This information is used by function kcdePage when a user asks for the 390-- dependents of a constructor. 391--============================================================================ 392mkDependentsHashTable() == --called by make-databases (database.boot) 393 $depTb := MAKE_HASHTABLE('EQUAL) 394 for nam in allConstructors() repeat 395 for con in getArgumentConstructors nam repeat 396 HPUT($depTb,con,[nam,:HGET($depTb,con)]) 397 for k in HKEYS $depTb repeat 398 HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k))) 399 $depTb 400 401getArgumentConstructors con == --called by mkDependentsHashTable 402 argtypes := IFCDR IFCAR getConstructorModemap con or return nil 403 fn argtypes where 404 fn(u) == "union"/[gn x for x in u] 405 gn(x) == 406 atom x => nil 407 x is ['Join,:r] => fn(r) 408 x is ['CATEGORY,:.] => nil 409 constructor? first x => [first x,:fn rest x] 410 fn rest x 411 412getImports conname == --called by mkUsersHashTable 413 conform := GETDATABASE(conname,'CONSTRUCTORFORM) 414 infovec := dbInfovec conname or return nil 415 template := infovec.0 416 u := [import(i,template) 417 for i in 5..(MAXINDEX template) | test] where 418 test == template.i is [op,:.] and IDENTP op 419 and not MEMQ(op,'(Mapping Union Record Enumeration CONS QUOTE local)) 420 import(x,template) == 421 x is [op,:args] => 422 op = 'QUOTE or op = 'NRTEVAL => first args 423 op = 'local => first args 424 op = 'Record => 425 ['Record,:[[":",CADR y,import(CADDR y,template)] for y in args]] 426 427--TTT next three lines: handles some tagged/untagged Union case. 428 op = 'Union=> 429 args is [['_:,:x1],:x2] => 430-- CAAR args = '_: => -- tagged! 431 ['Union,:[[":",CADR y,import(CADDR y,template)] for y in args]] 432 [op,:[import(y,template) for y in args]] 433 434 [op,:[import(y,template) for y in args]] 435 INTEGERP x => import(template.x,template) 436 x = '$ => '$ 437 x = "$$" => "$$" 438 STRINGP x => x 439 systemError '"bad argument in template" 440 listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u)) 441 442 443--============================================================================ 444-- Get Hierarchical Information 445--============================================================================ 446getParentsFor(cname,formalParams,constructorCategory) == 447--called by compDefineFunctor1 448 acc := nil 449 formals := TAKE(#formalParams,$TriangleVariableList) 450 constructorForm := GETDATABASE(cname, 'CONSTRUCTORFORM) 451 for x in folks constructorCategory repeat 452 x := SUBLISLIS(formalParams,formals,x) 453 x := SUBLISLIS(IFCDR constructorForm,formalParams,x) 454 acc := [:explodeIfs x,:acc] 455 NREVERSE acc 456 457parentsOf con == --called by kcpPage, ancestorsRecur 458 if null BOUNDP '$parentsCache then SETQ($parentsCache, MAKE_HASHTABLE('ID)) 459 HGET($parentsCache,con) or 460 parents := getParentsForDomain con 461 HPUT($parentsCache,con,parents) 462 parents 463 464parentsOfForm [op,:argl] == 465 parents := parentsOf op 466 null argl or argl = (newArgl := rest GETDATABASE(op,'CONSTRUCTORFORM)) => 467 parents 468 SUBLISLIS(argl, newArgl, parents) 469 470getParentsForDomain domname == --called by parentsOf 471 acc := nil 472 for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat 473 x := 474 GETDATABASE(domname,'CONSTRUCTORKIND) = 'category => 475 sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList) 476 sublisFormal(IFCDR getConstructorForm domname,x) 477 acc := [:explodeIfs x,:acc] 478 NREVERSE acc 479 480explodeIfs x == main where --called by getParents, getParentsForDomain 481 main == 482 x is ['IF,p,a,b] => fn(p,a,b) 483 [[x,:true]] 484 fn(p,a,b) == 485 [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]] 486 gn(p,a) == 487 a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil) 488 [[a,:p]] 489 490folks u == --called by getParents and getParentsForDomain 491 atom u => nil 492 u is [op,:v] and MEMQ(op,'(Join PROGN)) 493 or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v] 494 u is ['SIGNATURE,:.] => nil 495 u is ['TYPE,:.] => nil 496 u is ['ATTRIBUTE,a] => 497 PAIRP a and constructor? opOf a => folks a 498 nil 499 u is ['IF,p,q,r] => 500 q1 := folks q 501 r1 := folks r 502 q1 or r1 => [['IF,p,q1,r1]] 503 nil 504 [u] 505 506descendantsOf(conform,domform) == --called by kcdPage 507 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => 508 cats := catsOf(conform,domform) 509 [op,:argl] := conform 510 null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM))) 511 => cats 512 SUBLISLIS(argl, newArgl, cats) 513 'notAvailable 514 515childrenOf conform == 516 [pair for pair in descendantsOf(conform,nil) | 517 childAssoc(conform,parentsOfForm first pair)] 518 519childAssoc(form,alist) == 520 null (argl := rest form) => assoc(form, alist) 521 u := assocCar(opOf form, alist) => childArgCheck(argl, rest first u) and u 522 nil 523 524assocCar(x, al) == or/[pair for pair in al | x = CAAR pair] 525 526childArgCheck(argl, nargl) == 527 and/[fn for x in argl for y in nargl for i in 0..] where 528 fn == 529 x = y or constructor? opOf y => true 530 isSharpVar y => i = POSN1(y, $FormalMapVariableList) 531 false 532 533--computeDescendantsOf cat == 534--dynamically generates descendants 535-- hash := MAKE_HASHTABLE('UEQUAL) 536-- for [child,:pred] in childrenOf cat repeat 537-- childForm := getConstructorForm child 538-- HPUT(hash,childForm,pred) 539-- for [form,:pred] in descendantsOf(childForm,nil) repeat 540-- newPred := 541-- oldPred := HGET(hash,form) => quickOr(oldPred,pred) 542-- pred 543-- HPUT(hash,form,newPred) 544-- mySort [[key,:HGET(hash,key)] for key in HKEYS hash] 545 546ancestors_of_cat(conform, domform) == 547 conname := opOf(conform) 548 alist := GETDATABASE(conname,'ANCESTORS) 549 argl := IFCDR domform or IFCDR conform 550 [pair for [a,:b] in alist | pair] where pair == 551 left := sublisFormal(argl,a) 552 right := sublisFormal(argl,b) 553 if domform then right := simpHasPred right 554 null right => false 555 [left,:right] 556 557ancestorsOf(conform,domform) == --called by kcaPage, originsInOrder,... 558 'category = GETDATABASE((conname := opOf(conform)), 'CONSTRUCTORKIND) => 559 ancestors_of_cat(conform, domform) 560 computeAncestorsOf(conform,domform) 561 562computeAncestorsOf(conform,domform) == 563 $done : local := MAKE_HASHTABLE('UEQUAL) 564 $if : local := MAKE_HASHTABLE('ID) 565 ancestorsRecur(conform,domform,true,true) 566 acc := nil 567 for op in listSort(function GLESSEQP,HKEYS $if) repeat 568 for pair in HGET($if,op) repeat acc := [pair,:acc] 569 NREVERSE acc 570 571ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf 572 op := opOf conform 573 pred = HGET($done,conform) => nil --skip if already processed 574 parents := 575 firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => 576 $lisplibParents 577 parentsOf op 578 originalConform := 579 firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => 580 $functorForm 581 getConstructorForm op 582 if conform ~= originalConform then 583 parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents) 584 for [newform,:p] in parents repeat 585 if domform and rest domform then 586 newdomform := SUBLISLIS(rest domform,rest conform,newform) 587 p := SUBLISLIS(rest domform,rest conform,p) 588 newPred := quickAnd(pred,p) 589 ancestorsAdd(simpHasPred newPred,newdomform or newform) 590 ancestorsRecur(newform,newdomform,newPred,false) 591 HPUT($done,conform,pred) --mark as already processed 592 593ancestorsAdd(pred,form) == --called by ancestorsRecur 594 null pred => nil 595 op := IFCAR form or form 596 alist := HGET($if,op) 597 existingNode := assoc(form,alist) => 598 RPLACD(existingNode, quickOr(rest existingNode, pred)) 599 HPUT($if,op,[[form,:pred],:alist]) 600 601domainsOf(conform, domname) == 602 conname := opOf conform 603 u := [key for key in HKEYS $has_category_hash 604 | key is [anc,: =conname]] 605 --u is list of pairs (a . b) where b = conname 606 --we sort u then replace each b by the predicate for which this is true 607 s := listSort(function GLESSEQP,COPY u) 608 s := [[first pair, :GETDATABASE(pair, 'HASCATEGORY)] for pair in s] 609 transKCatAlist(conform,domname,listSort(function GLESSEQP,s)) 610 611catsOf(conform, domname) == 612 conname := opOf conform 613 alist := nil 614 for key in allConstructors() repeat 615 for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat 616 [[op,:args],:pred] := item 617 newItem := 618 args => [[args,:pred],:LASSOC(key,alist)] 619 pred 620 alist := insertShortAlist(key,newItem,alist) 621 transKCatAlist(conform,domname,listSort(function GLESSEQP,alist)) 622 623transKCatAlist(conform,domname,s) == main where 624 main == 625 domname => --accept only exact matches after substitution 626 domargs := rest domname 627 acc := nil 628 rest conform => 629 for pair in s repeat --pair has form [con,[conargs,:pred],...]] 630 leftForm := getConstructorForm first pair 631 for (ap := [args, :pred]) in rest pair repeat 632 match? := 633 domargs = args => true 634 HAS_SHARP_VAR args => domargs = sublisFormal(IFCDR domname, args) 635 nil 636 null match? => 'skip 637 npred := sublisFormal(IFCDR leftForm, pred) 638 acc := [[leftForm,:npred],:acc] 639 NREVERSE acc 640 --conform has no arguments so each pair has form [con,:pred] 641 for pair in s repeat 642 leftForm := getConstructorForm first pair or systemError nil 643 RPLACA(pair,leftForm) 644 RPLACD(pair, sublisFormal(IFCDR leftForm, rest pair)) 645 s 646 --no domname, so look for special argument combinations 647 acc := nil 648 IFCDR conform => 649 farglist := TAKE(#rest conform,$FormalMapVariableList) 650 for pair in s repeat --pair has form [con,[conargs,:pred],...]] 651 leftForm := getConstructorForm first pair 652 for (ap := [args, :pred]) in rest pair repeat 653 hasArgsForm? := args ~= farglist 654 npred := sublisFormal(IFCDR leftForm, pred) 655 if hasArgsForm? then 656 subargs := sublisFormal(IFCDR leftForm, args) 657 hpred := 658-- $hasArgsList => mkHasArgsPred subargs 659 ['hasArgs,:subargs] 660 npred := quickAnd(hpred,npred) 661 acc := [[leftForm,:npred],:acc] 662 NREVERSE acc 663 for pair in s repeat --pair has form [con,:pred] 664 leftForm := getConstructorForm first pair 665 RPLACA(pair,leftForm) 666 RPLACD(pair, sublisFormal(IFCDR leftForm, rest pair)) 667 s 668 669mkHasArgsPred subargs == 670--$hasArgsList gives arguments of original constructor,e.g. LODO(A,M) 671--M is required to be Join(B,...); in looking for the domains of B 672-- we can find that if B has special value C, it can 673 systemError subargs 674 675sublisFormal(args,exp,:options) == main where 676 main == --use only on LIST structures; see also sublisFormalAlist 677 $formals: local := IFCAR options or $FormalMapVariableList 678 null args => exp 679 sublisFormal1(args,exp,#args - 1) 680 sublisFormal1(args,x,n) == --[sublisFormal1(args,y) for y in x] 681 x is [.,:.] => 682 acc := nil 683 y := x 684 while null atom y repeat 685 acc := [sublisFormal1(args,QCAR y,n),:acc] 686 y := QCDR y 687 r := NREVERSE acc 688 if y then 689 nd := LASTNODE r 690 RPLACD(nd,sublisFormal1(args,y,n)) 691 r 692 IDENTP x => 693 j := or/[i for f in $formals for i in 0..n | EQ(f,x)] => 694 args.j 695 x 696 x 697 698--======================================================================= 699-- Build Table of Lower Case Constructor Names 700--======================================================================= 701 702buildDefaultPackageNamesHT() == 703 $defaultPackageNamesHT := MAKE_HASHTABLE('EQUAL) 704 for nam in allConstructors() | isDefaultPackageName nam repeat 705 HPUT($defaultPackageNamesHT,nam,true) 706 $defaultPackageNamesHT 707 708$defaultPackageNamesHT := buildDefaultPackageNamesHT() 709 710--======================================================================= 711-- Code for Private Libdbs 712--======================================================================= 713-- $createLocalLibDb := false 714 715extendLocalLibdb conlist == -- called by astran 716 not $createLocalLibDb => nil 717 null conlist => nil 718 buildLibdb conlist --> puts datafile into temp.text 719 $newConstructorList := union(conlist, $newConstructorList) 720 localLibdb := '"libdb.text" 721 not PROBE_-FILE '"libdb.text" => 722 RENAME_-FILE('"temp.text",'"libdb.text") 723 oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) 724 newlines := dbReadLines '"temp.text" 725 dbWriteLines(MSORT union(oldlines,newlines), '"libdb.text") 726 maybe_delete_file('"temp.text") 727