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 34--global hash tables for new compiler 35$docHash := MAKE_HASHTABLE('EQUAL) 36$conHash := MAKE_HASHTABLE('EQUAL) 37$opHash := MAKE_HASHTABLE('EQUAL) 38$asyPrint := false 39 40asList() == 41 maybe_delete_file('"temp.text") 42 OBEY '"ls as/*.asy > temp.text" 43 instream := OPEN '"temp.text" 44 lines := [read_line instream while not EOFP instream] 45 CLOSE instream 46 lines 47 48astran asyFile == 49--global hash tables for new compiler 50 $docHash := MAKE_HASHTABLE('EQUAL) 51 $conHash := MAKE_HASHTABLE('EQUAL) 52 $constantHash := MAKE_HASHTABLE('EQUAL) 53 $niladics : local := nil 54 $asyFile: local := asyFile 55 $asFilename: local := STRCONC(PATHNAME_-NAME asyFile,'".as") 56 asytran asyFile 57 conlist := [x for x in HKEYS $conHash | HGET($conHash,x) isnt [.,.,"function",:.]] 58 $mmAlist : local := 59 [[con,:asyConstructorModemap con] for con in conlist] 60 $docAlist : local := 61 [[con,:REMDUP asyDocumentation con] for con in conlist] 62 $parentsHash : local := MAKE_HASHTABLE('EQUAL) 63--$childrenHash: local := MAKE_HASHTABLE('EQUAL) 64 for con in conlist repeat 65 parents := asyParents con 66 HPUT($parentsHash,con,asyParents con) 67-- for [parent,:pred] in parents repeat 68-- parentOp := opOf parent 69-- HPUT($childrenHash,parentOp,insert([con,:pred],HGET($childrenHash,parentOp))) 70 $newConlist := union(conlist, $newConlist) 71 [[x,:asMakeAlist x] for x in HKEYS $conHash] 72 73asyParents(conform) == 74 acc := nil 75 con:= opOf conform 76--formals := TAKE(#formalParams,$TriangleVariableList) 77 modemap := LASSOC(con,$mmAlist) 78 $constructorCategory :local := asySubstMapping CADAR modemap 79 for x in folks $constructorCategory repeat 80-- x := SUBLISLIS(formalParams,formals,x) 81-- x := SUBLISLIS(IFCDR conform,formalParams,x) 82 acc := [:explodeIfs x,:acc] 83 NREVERSE acc 84 85asySubstMapping u == 86 u is [op,:r] => 87 op = "->" => 88 [s, t] := r 89 args := 90 s is [op,:u] and asyComma? op => [asySubstMapping y for y in u] 91 [asySubstMapping s] 92 ['Mapping, asySubstMapping t, :args] 93 [asySubstMapping x for x in u] 94 u 95 96asyMkSignature(con,sig) == 97-- atom sig => ['TYPE,con,sig] 98-- following line converts constants into nullary functions 99 atom sig => ['SIGNATURE,con,[sig]] 100 ['SIGNATURE,con,sig] 101 102asMakeAlist con == 103 record := HGET($conHash,con) 104 [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record 105--TTT in case we put the wrong thing in for niladic catgrs 106--if ATOM(form) and kind='category then form:=[form] 107 if ATOM(form) then form:=[form] 108 kind = 'function => asMakeAlistForFunction con 109 abb := asyAbbreviation(con, #(IFCDR sig)) 110 if null IFCDR form then PUT(opOf form, 'NILADIC, 'T) 111 modemap := asySubstMapping LASSOC(con,$mmAlist) 112 $constructorCategory :local := CADAR modemap 113 parents := mySort HGET($parentsHash,con) 114--children:= mySort HGET($childrenHash,con) 115 alists := HGET($opHash,con) 116 opAlist := SUBLISLIS($FormalMapVariableList, IFCDR form, CDDR alists) 117 ancestorAlist := SUBLISLIS($FormalMapVariableList, IFCDR form, first alists) 118 catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory] 119 attributeAlist := REMDUP [:CADR alists,:catAttrs] 120 documentation := 121 SUBLISLIS($FormalMapVariableList, IFCDR form, LASSOC(con, $docAlist)) 122 filestring := STRCONC(PATHNAME_-NAME STRINGIMAGE filename,'".as") 123 constantPart := HGET($constantHash,con) and [['constant,:true]] 124 niladicPart := MEMQ(con,$niladics) and [['NILADIC,:true]] 125 falist := TAKE(#IFCDR form, $FormalMapVariableList) 126 constructorCategory := 127 kind = 'category => 128 talist := TAKE(#IFCDR form, $TriangleVariableList) 129 SUBLISLIS(talist, falist, $constructorCategory) 130 SUBLISLIS(falist, IFCDR form, $constructorCategory) 131 if constructorCategory='Category then kind := 'category 132 exportAlist := asGetExports(kind, form, constructorCategory) 133 constructorModemap := SUBLISLIS(falist, IFCDR form, modemap) 134--TTT fix a niladic category constructormodemap (remove the joins) 135 if kind = 'category then 136 SETF(CADAR(constructorModemap),['Category]) 137 res := [['constructorForm,:form],:constantPart,:niladicPart, 138 ['constructorKind,:kind], 139 ['constructorModemap,:constructorModemap], 140 ['abbreviation,:abb], 141 ['constructorCategory,:constructorCategory], 142 ['parents,:parents], 143 ['attributes,:attributeAlist], 144 ['ancestors,:ancestorAlist], 145 -- ['children,:children], 146 ['sourceFile,:filestring], 147 ['operationAlist,:zeroOneConversion opAlist], 148 ['modemaps,:asGetModemaps(exportAlist,form,kind,modemap)], 149 ['sourcefile,:$asFilename], 150 ['typeCode,:typeCode], 151 ['documentation,:documentation]] 152 if $asyPrint then asyDisplay(con,res) 153 res 154 155asGetExports(kind, conform, catform) == 156 [., :op_lst] := categoryParts1(kind, conform, catform, false) or return nil 157 -- ensure that signatures are lists 158 [[op, sigpred] for [op,sig,:pred] in op_lst] where 159 sigpred == 160 pred := 161 pred = "T" => nil 162 pred 163 [sig, nil, :pred] 164 165asMakeAlistForFunction fn == 166 record := HGET($conHash,fn) 167 [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record 168 modemap := LASSOC(fn,$mmAlist) 169 newsig := asySignature(sig,nil) 170 opAlist := [[fn,[newsig,nil,:predlist]]] 171 res := [['modemaps,:asGetModemaps(opAlist,fn,'function,modemap)], 172 ['typeCode,:typeCode]] 173 if $asyPrint then asyDisplay(fn,res) 174 res 175 176getAttributesFromCATEGORY catform == 177 catform is ['CATEGORY,.,:r] => [y for x in r | x is ['ATTRIBUTE,y]] 178 catform is ['Join,:m,x] => getAttributesFromCATEGORY x 179 nil 180 181displayDatabase x == main where 182 main == 183 for y in 184 '(CONSTRUCTORFORM CONSTRUCTORKIND _ 185 CONSTRUCTORMODEMAP _ 186 ABBREVIATION _ 187 CONSTRUCTORCATEGORY _ 188 PARENTS _ 189 ANCESTORS _ 190 SOURCEFILE _ 191 OPERATIONALIST _ 192 MODEMAPS _ 193 SOURCEFILE _ 194 DOCUMENTATION) repeat fn(x,y) 195 fn(x,y) == 196 sayBrightly ['"----------------- ",y,'" --------------------"] 197 pp GETDATABASE(x,y) 198 199-- For some reason Dick has modified as.boot to convert the 200-- identifier |0| or |1| to an integer in the list of operations. 201-- This is WRONG, all existing code assumes that operation names 202-- are always identifiers not numbers. 203-- This function breaks the ability of the interpreter to find 204-- |0| or |1| as exports of new compiler domains. 205-- Unless someone has a strong reason for keeping the change, 206-- this function should be no-opped, i.e. 207-- zeroOneConversion opAlist == opAlist 208-- If this change is made, then we are able to find asharp constants again. 209-- bmt Mar 26, 1994 and executed by rss 210 211zeroOneConversion opAlist == opAlist 212-- for u in opAlist repeat 213-- [op,:.] := u 214-- DIGITP (PNAME op).0 => RPLACA(u, string2Integer PNAME op) 215-- opAlist 216 217asyDisplay(con,alist) == 218 banner := '"==============================" 219 sayBrightly [banner,'" ",con,'" ",banner] 220 for [prop,:value] in alist repeat 221 sayBrightlyNT [prop,'": "] 222 pp value 223 224asGetModemaps(opAlist,oform,kind,modemap) == 225 acc:= nil 226 rpvl:= 227 MEMQ(kind, '(category function)) => rest $PatternVariableList -- *1 is special for $ 228 $PatternVariableList 229 form := [opOf oform, :[y for x in IFCDR oform for y in rpvl]] 230 dc := 231 MEMQ(kind, '(category function)) => "*1" 232 form 233 pred1 := 234 kind = 'category => [["*1",form]] 235 nil 236 signature := CDAR modemap 237 domainList := 238 [[a,m] for a in rest form for m in rest signature | 239 asIsCategoryForm m] 240 catPredList:= 241 kind = 'function => [["isFreeFunction","*1",opOf form]] 242 [['ofCategory,:u] for u in [:pred1,:domainList]] 243-- for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat 244-- the code seems to oscillate between generating $FormalMapVariableList 245-- and generating $TriangleVariableList 246 for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat 247 for [sig0, pred] in itemlist repeat 248 sig := SUBST(dc,"$",sig0) 249 pred:= SUBST(dc,"$",pred) 250 sig := SUBLISLIS(rpvl, IFCDR oform, sig) 251 pred:= SUBLISLIS(rpvl, IFCDR oform, pred) 252 pred := pred or 'T 253 ----------> Constants change <-------------- 254 if IDENTP sig0 then 255 sig := [sig] 256 pred := MKPF([pred,'(isAsConstant)],'AND) 257 pred' := MKPF([pred,:catPredList],'AND) 258 mm := [[dc,:sig],[pred']] 259 acc := [[op,:interactiveModemapForm mm],:acc] 260 NREVERSE acc 261 262asIsCategoryForm m == 263 m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category 264 265asyDocumentation con == 266 docHash := HGET($docHash,con) 267 u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash 268 | rec := HGET(docHash,op)] where fn(x,op) == 269 [form,sig,pred,origin,where?,comments,:.] := x 270 ----------> Constants change <-------------- 271 if IDENTP sig then sig := [sig] 272 [asySignature(sig,nil),trimComments comments] 273 [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) 274 --above "first" assumes only one entry 275 comments := trimComments asyExtractDescription comments 276 [:u,['constructor,[nil,comments]]] 277 278asyExtractDescription str == 279 k := STRPOS('"Description:",str,0,nil) => asyExtractDescription SUBSTRING(str,k + 12,nil) 280 k := STRPOS('"Author:",str,0,nil) => asyExtractDescription SUBSTRING(str,0,k) 281 str 282 283trimComments str == 284 null str or str = '"" => '"" 285 m := MAXINDEX str 286 str := SUBSTRING(str,0,m) 287 trimString str 288 289asyExportAlist con == 290--format of 'operationAlist property of LISPLIBS (as returned from koOps): 291-- <sig slotNumberOrNil optPred optELT> 292--!!! asyFile NEED: need to know if function is implemented by domain!!! 293 docHash := HGET($docHash,con) 294 [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)] 295 where fn(x,op) == 296 [form,sig,pred,origin,where?,comments,:.] := x 297 tail := 298 pred => [pred] 299 nil 300 newSig := asySignature(sig,nil) 301 [newSig,nil,:tail] 302 303asyMakeOperationAlist(con,proplist, key) == 304 oplist := 305 u := LASSOC('domExports,proplist) => 306 kind := 'domain 307 u 308 u := LASSOC('catExports,proplist) => 309 kind := 'category 310 u 311 key = 'domain => 312 kind := 'domain 313 u := NIL 314 return nil 315 ht := MAKE_HASHTABLE('EQUAL) 316 ancestorAlist := nil 317 for ['Declare,id,form,r] in oplist repeat 318 id = "%%" => 319 opOf form = con => nil 320 y := asyAncestors form 321 if opOf(y)~=con then ancestorAlist := [ [y,:true],:ancestorAlist] 322 idForm := 323 form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] 324 ----------> Constants change <-------------- 325 id 326 pred := 327 LASSOC('condition,r) is p => hackToRemoveAnd p 328 nil 329 sig := asySignature(asytranForm(form,[idForm],nil),nil) 330 entry := 331 --id ~= "%%" and IDENTP idForm => [[sig],nil,nil,'ASCONST] 332 id ~= "%%" and IDENTP idForm => 333 pred => [[sig],nil,asyPredTran pred,'ASCONST] 334 [[sig],nil,true,'ASCONST] 335 pred => [sig,nil,asyPredTran pred] 336 [sig] 337 HPUT(ht,id,[entry,:HGET(ht,id)]) 338 opalist := [[op,:REMDUP HGET(ht,op)] for op in HKEYS ht] 339 HPUT($opHash,con,[ancestorAlist,nil,:opalist]) 340 341hackToRemoveAnd p == 342---remove this as soon as .asy files do not contain forms (And pred) forms 343 p is ['And,q,:r] => 344 r => ['AND,q,:r] 345 q 346 p 347 348asyAncestors x == 349 x is ['Apply,:r] => asyAncestorList r 350 x is [op,y,:.] and MEMQ(op, '(PretendTo RestrictTo)) => asyAncestors y 351 atom x => 352 x = '_% => '_$ 353 MEMQ(x, $niladics) => [x] 354 GETDATABASE(x ,'NILADIC) => [x] 355 x 356 asyAncestorList x 357 358asyAncestorList x == [asyAncestors y for y in x] 359--============================================================================ 360-- Build Operation Alist from sig 361--============================================================================ 362 363--format of operations as returned from koOps 364-- <sig pred pakOriginOrNil TifPakExposedOrNil> 365-- <sig pred origin exposed?> 366 367--abb,kind,file,sourcefile,coSig,dbLineNumber,constructorArgs,libfile 368--((sig where(NIL or #) condition(T or pred) ELT) ... 369--expanded lists are: sig, predicate, origin, exposeFlag, comments 370 371--============================================================================ 372-- Building Hash Tables for Operations/Constructors 373--============================================================================ 374asytran fn == 375--put operations into table format for browser: 376-- <sig pred origin exposed? comments> 377 inStream := OPEN fn 378 sayBrightly ['" Reading ",fn] 379 u := VMREAD inStream 380 $niladics := mkNiladics u 381 for x in $niladics repeat PUT(x,'NILADIC,true) 382 for d in u repeat 383 ['Declare,name,:.] := d 384 name = "%%" => 'skip --skip over top-level properties 385 $docHashLocal: local := MAKE_HASHTABLE('EQUAL) 386 asytranDeclaration(d,'(top),nil,false) 387 if null name then BREAK() 388 HPUT($docHash,name,$docHashLocal) 389 CLOSE inStream 390 'done 391 392mkNiladics u == 393 [name for x in u | x is ['Declare,name,y,:.] and y isnt ['Apply,'_-_>,:.]] 394 395asytranDeclaration(dform,levels,predlist,local?) == 396 ['Declare,id,form,r] := dform 397 id = 'failed => id 398 IFCAR dform ~= 'Declare => systemError '"asytranDeclaration" 399 if levels = '(top) then 400 if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) 401 comments := LASSOC('documentation,r) or '"" 402 idForm := 403 levels is ['top,:.] => 404 form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] 405 id 406 ----------> Constants change <-------------- 407 id 408 newsig := asytranForm(form,[idForm,:levels],local?) 409 key := 410 levels is ['top,:.] => 411 MEMQ(id,'(%% Category Type)) => 'constant 412 asyLooksLikeCatForm? form => 'category 413 form is ['Apply, '_-_>,.,u] => 414 if u is ['Apply, construc,:.] then u:= construc 415 GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain => 'function 416 asyLooksLikeCatForm? u => 'category 417 'domain 418 'domain 419 first levels 420 typeCode := LASSOC('symeTypeCode,r) 421 record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile] 422 if not local? then 423 ht := 424 levels = '(top) => $conHash 425 $docHashLocal 426 HPUT(ht,id,[record,:HGET(ht,id)]) 427 if levels = '(top) then asyMakeOperationAlist(id,r, key) 428 ['Declare,id,newsig,r] 429 430asyLooksLikeCatForm? x == 431--TTT don't see a Third in my version .... 432 x is ['Define, ['Declare, ., ['Apply, 'Third,:.],:.],:.] or 433 x is ['Define, ['Declare, ., 'Category ],:.] 434 435asyIsCatForm form == 436 form is ['Apply,:r] => 437 r is ['_-_>,.,a] => asyIsCatForm a 438 r is ['Third,'Type,:.] => true 439 false 440 false 441 442asyArgs source == 443 args := 444 source is [op,:u] and asyComma? op => u 445 [source] 446 [asyArg x for x in args] 447 448asyArg x == 449 x is ['Declare,id,:.] => id 450 x 451 452asyMkpred predlist == 453 null predlist => nil 454 predlist is [p] => p 455 ['AND,:predlist] 456 457asytranForm(form,levels,local?) == 458 u := asytranForm1(form,levels,local?) 459 null u => hahah() 460 u 461 462asytranForm1(form,levels,local?) == 463 form is ['With,left,cat] => 464-- left ~= nil => error '"WITH cannot take a left argument yet" 465 asytranCategory(form,levels,nil,local?) 466 form is ['Apply,:.] => asytranApply(form,levels,local?) 467 form is ['Declare,:.] => asytranDeclaration(form,levels,nil,local?) 468 form is ['Comma,:r] => ['Comma,:[asytranForm(x,levels,local?) for x in r]] 469--form is ['_-_>,:s] => asytranMapping(s,levels,local?) 470 form is [op,a,b] and MEMQ(a,'(PretendTo RestrictTo)) => 471 asytranForm1(a,levels,local?) 472 form is ['LitInteger,s] => 473 READ_-FROM_-STRING(s) 474 form is ['Define,:.] => 475 form is ['Define,['Declare,.,x,:.],rest] => 476--TTT i don't know about this one but looks ok 477 x = 'Category => asytranForm1(rest,levels, local?) 478 asytranForm1(x,levels,local?) 479 error '"DEFINE forms are not handled yet" 480 if form = '_% then $hasPerCent := true 481 IDENTP form => 482 form = "%" => "$" 483 GETL(form,'NILADIC) => [form] 484 form 485 [asytranForm(x,levels,local?) for x in form] 486 487asytranApply(['Apply,name,:arglist],levels,local?) == 488 MEMQ(name,'(Record Union)) => 489 [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]] 490 null arglist => [name] 491 name is [ 'RestrictTo, :.] => 492 asytranApply(['Apply, first rest name, :arglist], levels, local?) 493 name is [ 'Qualify, :.] => 494 asytranApply(['Apply, first rest name, :arglist], levels, local?) 495 name is 'string => asytranLiteral first arglist 496 name is 'integer => asytranLiteral first arglist 497 name is 'float => asytranLiteral first arglist 498 name = 'Enumeration => 499 ["Enumeration",:[asytranEnumItem arg for arg in arglist]] 500 [:argl,lastArg] := arglist 501 [name,:[asytranFormSpecial(arg,levels,true) for arg in argl], 502 asytranFormSpecial(lastArg,levels,false)] 503 504asytranLiteral(lit) == 505 first rest lit 506 507asytranEnumItem arg == 508 arg is ['Declare, name, :.] => name 509 error '"Bad Enumeration entry" 510 511asytranApplySpecial(x, levels, local?) == 512 x is ['Declare, name, typ, :.] => [":",name,asytranForm(typ, levels, local?)] 513 asytranForm(x, levels, local?) 514 515asytranFormSpecial(x, levels, local?) == --> this throws away variable name (revise later) 516 x is ['Declare, name, typ, :.] => asytranForm(typ, levels, local?) 517 asytranForm(x, levels, local?) 518 519asytranCategory(form,levels,predlist,local?) == 520 cat := 521 form is ['With,left,right] => 522 right is ['Blank,:.] => ['Sequence] 523 right 524 form 525 left := 526 form is ['With,left,right] => 527 left is ['Blank,:.] => nil 528 left 529 nil 530 $hasPerCent: local := nil 531 items := 532 cat is ['Sequence,:s] => s 533 [cat] 534 catTable := MAKE_HASHTABLE('EQUAL) 535 catList := nil 536 for x in items | x repeat 537 if null x then systemError() 538 dform := asytranCategoryItem(x,levels,predlist,local?) 539 null dform => nil 540 dform is ['Declare,id,record,r] => 541 HPUT(catTable,id,[asyWrap(record,predlist),:HGET(catTable,id)]) 542 catList := [asyWrap(dform,predlist),:catList] 543 keys := listSort(function GLESSEQP,HKEYS catTable) 544 right1 := NREVERSE catList 545 right2 := [[key,:HGET(catTable,key)] for key in keys] 546 right := 547 right2 => [:right1,['Exports,:right2]] 548 right1 549 res := 550 left => [left,:right] 551 right 552 res is [x] and x is ['IF,:.] => x 553 ['With,:res] 554 555asyWrap(record,predlist) == 556 predlist => ['IF,MKPF(predlist,'AND),record] 557 record 558 559asytranCategoryItem(x,levels,predlist,local?) == 560 x is ['If,predicate,item,:r] => 561 IFCAR r => error '"ELSE expressions not allowed yet in conditionals" 562 pred := 563 predicate is ['Test,r] => r 564 predicate 565 asytranCategory(item,levels,[pred,:predlist],local?) 566 MEMQ(IFCAR x, '(Default Foreign)) => nil 567 x is ['Declare,:.] => asytranDeclaration(x,levels,predlist,local?) 568 x 569 570--============================================================================ 571-- Extending Constructor Datatable 572--============================================================================ 573--FORMAT of $constructorDataTable entry: 574--abb kind libFile sourceFile coSig constructorArgs 575--alist is ((kind . domain) (libFile . MATRIX) (sourceFile . "matrix") 576-- (coSig NIL T) (dbLineNumber . 29187) (constructorArgs R) 577-- (modemap . ( 578-- (|Matrix| |#1|) 579-- (Join (MatrixCategory #1 (Vector #1) (Vector #1)) 580-- (CATEGORY domain 581-- (SIGNATURE diagonalMatrix ($ (Vector #1))) 582-- (IF (has #1 (Field)) 583-- (SIGNATURE inverse ((Union $ "failed") $)) noBranch))) 584-- (Ring)) 585-- (T Matrix)) ) 586extendConstructorDataTable() == 587 for x in listSort(function GLESSEQP,HKEYS $conHash) repeat 588 record := HGET($conHash,x) 589 [form,sig,predlist,origin,exposure,comments,typeCode,:filename] := first record 590 abb := asyAbbreviation(x,#(rest sig)) 591 kind := 'domain 592 --Note: this "first" assumes that there is ONLY one sig per name 593 cosig := [nil,:asyCosig sig] 594 args := asyConstructorArgs sig 595 tb := 596 [[x,abb, 597 ['kind,:kind], 598 ['cosig,:cosig], 599 ['libfile,filename], 600 ['sourceFile,STRINGIMAGE filename], 601 ['constructorArgs,:args]],:tb] 602 listSort(function GLESSEQP,ASSOCLEFT tb) 603 604asyConstructorArgs sig == 605 sig is ['With,:.] => nil 606 sig is ['_-_>,source,target] => 607 source is [op,:argl] and asyComma? op => [asyConstructorArg x for x in argl] 608 [asyConstructorArg source] 609 610asyConstructorArg x == 611 x is ['Declare,name,t,:.] => name 612 x 613 614asyCosig sig == --can be a type or could be a signature 615 atom sig or sig is ['With,:.] => nil 616 sig is ['_-_>,source,target] => 617 source is [op,:argl] and asyComma? op => [asyCosigType x for x in argl] 618 [asyCosigType source] 619 error false 620 621asyCosigType u == 622 u is [name,t] => 623 t is [fn,:.] => 624 asyComma? fn => fn 625 fn = 'With => 'T 626 nil 627 t = 'Type => 'T 628 error '"Unknown atomic type" 629 error false 630 631asyAbbreviation(id,n) == chk(id,main) where --> n = number of arguments 632 main == 633 a := createAbbreviation id => a 634 name := PNAME id 635-- #name < 8 => INTERN UPCASE name 636 parts := asySplit(name,MAXINDEX name) 637 newname := "STRCONC"/[asyShorten x for x in parts] 638 #newname < 8 => INTERN newname 639 tryname := SUBSTRING(name,0,7) 640 not createAbbreviation tryname => INTERN UPCASE tryname 641 nil 642 chk(conname,abb) == 643 (xx := asyGetAbbrevFromComments conname) => xx 644 con := abbreviation? abb => 645 conname = con => abb 646 conname 647 abb 648 649asyGetAbbrevFromComments con == 650 docHash := HGET($docHash,con) 651 u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash 652 | rec := HGET(docHash,op)] where fn(x,op) == 653 [form,sig,pred,origin,where?,comments,:.] := x 654 ----------> Constants change <-------------- 655 if IDENTP sig then sig := [sig] 656 [asySignature(sig,nil),trimComments comments] 657 [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) 658 --above "first" assumes only one entry 659 x := asyExtractAbbreviation comments 660 x => intern x 661 NIL 662 663asyExtractAbbreviation str == 664 not (k:= STRPOS('"Abbrev: ",str,0,nil)) => NIL 665 str := SUBSTRING(str, k+8, nil) 666 k := STRPOS($stringNewline, str,0,nil) 667 k => SUBSTRING(str, 0, k) 668 str 669 670asyShorten x == 671 y := createAbbreviation x 672 or LASSOC(x, 673 '(("Small" . "SM") ("Single" ."S") ("Half" . "H")("Point" . "PT") 674 ("Floating" . "F") ("System" . "SYS") ("Number" . "N") 675 ("Inventor" . "IV") 676 ("Finite" . "F") ("Double" . "D") ("Builtin" . "BI"))) => y 677 UPCASE x 678 679asySplit(name,end) == 680 end < 1 => [name] 681 k := 0 682 for i in 1..end while LOWER_-CASE_-P name.i repeat k := i 683 k := k + 1 684 [SUBSTRING(name,0,k),:asySplit(SUBSTRING(name,k,nil),end-k)] 685 686createAbbreviation s == 687 if STRINGP s then s := INTERN s 688 a := constructor? s 689 a ~= s => a 690 nil 691 692--============================================================================ 693-- extending getConstructorModemap Property 694--============================================================================ 695--Note: modemap property is built when getConstructorModemap is called 696 697asyConstructorModemap con == 698 HGET($conHash,con) isnt [record,:.] => nil --not there 699 [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := record 700 $kind: local := kind 701 --NOTE: sig has the form (-> source target) or simply (target) 702 $constructorArgs : local := IFCDR form 703 signature := asySignature(sig,false) 704 formals := ['_$,:TAKE(#$constructorArgs,$FormalMapVariableList)] 705 mm := [[[con,:$constructorArgs],:signature],['T,con]] 706 SUBLISLIS(formals,['_%,:$constructorArgs],mm) 707 708asySignature(sig,names?) == 709 sig is ['Join,:.] => [asySig(sig,nil)] 710 sig is ['With,:.] => [asySig(sig,nil)] 711 sig is ['_-_>,source,target] => 712 target := 713 names? => ['dummy,target] 714 target 715 source is [op,:argl] and asyComma? op => 716 [asySigTarget(target,names?),:[asySig(x,names?) for x in argl]] 717 [asySigTarget(target,names?),asySig(source,names?)] 718 ----------> The following is a hack for constants which are category names<-- 719 sig is ['Third,:.] => [asySig(sig,nil)] 720 ----------> Constants change <-------------- 721 asySig(sig,nil) 722 723asySigTarget(u,name?) == asySig1(u,name?,true) 724 725asySig(u,name?) == asySig1(u,name?,false) 726 727asySig1(u,name?,target?) == 728 x := 729 name? and u is [name,t] => t 730 u 731 x is [fn,:r] => 732 fn = 'Join => asyTypeJoin r ---------> jump out to newer code 4/94 733 MEMQ(fn, '(RestrictTo PretendTo)) => asySig(first r,name?) 734 asyComma? fn => 735 u := [asySig(x,name?) for x in r] 736 target? => 737 null u => '(Void) 738 -- this implies a multiple value return, not currently supported 739 -- in the interpreter 740 ['Multi,:u] 741 u 742 fn = 'With => asyCATEGORY r 743 fn = 'Third => 744 r is [b] => 745 b is ['With,:s] => asyCATEGORY s 746 b is ['Blank,:.] => asyCATEGORY nil 747 error x 748 fn = 'Apply and r is ['_-_>,:s] => asyMapping(s,name?) 749 fn = '_-_> => asyMapping(r,name?) 750 fn = 'Declare and r is [name,typ,:.] => 751 asySig1(typ, name?, target?) 752 x is '(_%) => '(_$) 753 [fn,:[asySig(x,name?) for x in r]] 754--x = 'Type => '(Type) 755 x = '_% => '_$ 756 x 757 758asyMapping([a,b],name?) == 759 newa := asySig(a,name?) 760 b := asySig(b,name?) 761 args := 762 a is [op,:r] and asyComma? op => newa 763 [a] 764 ['Mapping,b,:args] 765 766--============================================================================ 767-- code for asySignatures of the form (Join,:...) 768--============================================================================ 769asyType x == 770 x is [fn,:r] => 771 fn = 'Join => asyTypeJoin r 772 MEMQ(fn, '(RestrictTo PretendTo)) => asyType first r 773 asyComma? fn => 774 u := [asyType x for x in r] 775 u 776 fn = 'With => asyCATEGORY r 777 fn = '_-_> => asyTypeMapping r 778 fn = 'Apply => r 779-- fn = 'Declare and r is [name,typ,:.] => typ 780 x is '(_%) => '(_$) 781 x 782--x = 'Type => '(Type) 783 x = '_% => '_$ 784 x 785 786asyTypeJoin r == 787 $conStack : local := nil 788 $opStack : local := nil 789 $predlist : local := nil 790 for x in r repeat asyTypeJoinPart(x,$predlist) 791 catpart := 792 $opStack => ['CATEGORY,$kind,:asyTypeJoinStack REVERSE $opStack] 793 nil 794 conpart := asyTypeJoinStack REVERSE $conStack 795 conpart => 796 catpart => ['Join,:conpart,catpart] 797 rest conpart => ['Join, :conpart] 798 conpart 799 catpart 800 801asyTypeJoinPart(x,$predlist) == 802 x is ['Join,:y] => for z in y repeat asyTypeJoinPart(z, $predlist) 803 x is ['With,:y] => for p in y repeat asyTypeJoinPartWith p 804 asyTypeJoinPartWith x 805 806asyTypeJoinPartWith x == 807 x is ['Exports,:y] => for p in y repeat asyTypeJoinPartExport p 808 x is ['Exports,:.] => systemError 'exports 809 x is ['Comma] => nil 810 x is ['Export,:y] => nil 811 x is ['IF,:r] => asyTypeJoinPartIf r 812 x is ['Sequence,:x] => for y in x repeat asyTypeJoinItem y 813 asyTypeJoinItem x 814 815asyTypeJoinPartIf [pred,value] == 816 predlist := [asyTypeJoinPartPred pred,:$predlist] 817 asyTypeJoinPart(value,predlist) 818 819asyTypeJoinPartPred x == 820 x is ['Test, y] => asyTypeUnit y 821 asyTypeUnit x 822 823asyTypeJoinItem x == 824 result := asyTypeUnit x 825 isLowerCaseLetter (PNAME opOf result).0 => 826 $opStack := [[['ATTRIBUTE,result],:$predlist],:$opStack] 827 $conStack := [[result,:$predlist],:$conStack] 828 829asyTypeMapping([a,b]) == 830 a := asyTypeUnit a 831 b := asyTypeUnit b 832 args := 833 a is [op,:r] and asyComma? op => r 834 [a] 835 ['Mapping,b,:args] 836 837asyTypeUnit x == 838 x is [fn,:r] => 839 fn = 'Join => systemError 'Join ----->asyTypeJoin r 840 MEMQ(fn, '(RestrictTo PretendTo)) => asyTypeUnit first r 841 asyComma? fn => 842 u := [asyTypeUnit x for x in r] 843 u 844 fn = 'With => asyCATEGORY r 845 fn = '_-_> => asyTypeMapping r 846 fn = 'Apply => asyTypeUnitList r 847 fn = 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ) 848 x is '(_%) => '(_$) 849 [fn,:asyTypeUnitList r] 850 GETL(x,'NILADIC) => [x] 851--x = 'Type => '(Type) 852 x = '_% => '_$ 853 x 854 855asyTypeUnitList x == [asyTypeUnit y for y in x] 856 857asyTypeUnitDeclare(op,typ) == 858 typ is ['Apply, :r] => asyCatSignature(op,r) 859 asyTypeUnit typ 860--============================================================================ 861-- Translator for ['With,:.] 862--============================================================================ 863asyCATEGORY x == 864 if x is [join,:y] and join is ['Apply,:s] then 865 exports := y 866 joins := 867 s is ['Join,:r] => [asyJoinPart u for u in r] 868 [asyJoinPart s] 869 else if x is [id,:y] and IDENTP id then 870 joins := [[id]] 871 exports := y 872 else 873 joins := nil 874 exports := x 875 cats := exports 876 operations := nil 877 if exports is [:r,['Exports,:ops]] then 878 cats := r 879 operations := ops 880 exportPart := 881 ['CATEGORY,'domain,:"APPEND"/[asyCatItem y for y in operations]] 882 cats := "append"/[asyCattran c for c in cats] 883 joins or cats => 884 ['Join,:joins,:cats, exportPart] 885 exportPart 886 887simpCattran x == 888 u := asyCattran x 889 u is [y] => y 890 ['Join,:u] 891 892asyCattran x == 893 x is ['With,:r] => "append"/[asyCattran1 x for x in r] 894 x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] 895 [x] 896 897asyCattran1 x == 898 x is ['Exports,:y] => "append"/[asyCattranOp u for u in y] 899 x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] 900 systemError nil 901 902asyCattranOp [op,:items] == 903 "append"/[asyCattranOp1(op,item,nil) for item in items] 904 905asyCattranOp1(op, item, predlist) == 906 item is ['IF, p, x] => 907 pred := asyPredTran 908 p is ['Test,t] => t 909 p 910-- x is ['IF,:.] => "append"/[asyCattranOp1('IF, x, [pred,:predlist])] 911-- This line used to call asyCattranOp1 with too few arguments. Following 912-- fix suggested by RDJ. 913 x is ['IF,:.] => "append"/[asyCattranOp1(op,y,[pred,:predlist]) for y in x] 914 [['IF, asySimpPred(pred,predlist), asyCattranSig(op,x), 'noBranch]] 915 [asyCattranSig(op,item)] 916 917asyPredTran p == asyPredTran1 asyJoinPart p 918 919asyPredTran1 p == 920 p is ['Has,x,y] => ['has,x, simpCattran y] 921 p is ['Test, q] => asyPredTran1 q 922 p is [op,:r] and MEMQ(op,'(AND OR NOT)) => 923 [op,:[asyPredTran1 q for q in r]] 924 p 925 926asyCattranConstructors(item, predlist) == 927 item is ['IF, p, x] => 928 pred := asyPredTran 929 p is ['Test,t] => t 930 p 931 x is ['IF,:.] => "append"/[asyCattranConstructors(x, [pred,:predlist])] 932 form := ['ATTRIBUTE, asyJoinPart x] 933 [['IF, asySimpPred(pred,predlist), form, 'noBranch]] 934 systemError() 935 936asySimpPred(p, predlist) == 937 while predlist is [q,:predlist] repeat p := quickAnd(q,p) 938 p 939 940asyCattranSig(op,y) == 941 y isnt ["->",source,t] => 942-- following makes constants into nullary functions 943 ['SIGNATURE, op, [asyTypeUnit y]] 944 s := 945 source is ['Comma,:s] => [asyTypeUnit z for z in s] 946 [asyTypeUnit source] 947 t := asyTypeUnit t 948 null t => ['SIGNATURE,op,s] 949 ['SIGNATURE,op,[t,:s]] 950 951asyJoinPart x == 952 IDENTP x => [x] 953 asytranForm(x,nil,true) 954 955asyCatItem item == 956 atom item => [item] 957 item is ['IF,.,.] => [item] 958 [op,:sigs] := item 959 [asyCatSignature(op,sig) for sig in sigs | sig] 960 961asyCatSignature(op,sig) == 962 sig is ['_-_>,source,target] => 963 ['SIGNATURE,op, [asyTypeItem target,:asyUnTuple source]] 964 ----------> Constants change <-------------- 965-- following line converts constants into nullary functions 966 ['SIGNATURE,op,[asyTypeItem sig]] 967 968asyUnTuple x == 969 x is [op,:u] and asyComma? op => [asyTypeItem y for y in u] 970 [asyTypeItem x] 971 972asyTypeItem x == 973 atom x => 974 x = '_% => '_$ 975 x 976 x is ['_-_>,a,b] => 977 ['Mapping,b,:asyUnTuple a] 978 x is ['Apply,:r] => 979 r is ['_-_>,a,b] => 980 ['Mapping,b,:asyUnTuple a] 981 r is ['Record,:parts] => 982 ['Record,:[[":",a,b] for ['Declare,a,b,:.] in parts]] 983 r is ['Segment,:parts] => 984 ['Segment,:[asyTypeItem x for x in parts]] 985 asytranApply(x,nil,true) 986 x is ['Declare,.,t,:.] => asyTypeItem t 987 x is ['Comma,:args] => 988 -- this implies a multiple value return, not currently supported 989 -- in the interpreter 990 args => ['Multi,:[asyTypeItem y for y in args]] 991 ['Void] 992 [asyTypeItem y for y in x] 993 994--============================================================================ 995-- Utilities 996--============================================================================ 997asyComma? op == MEMQ(op,'(Comma Multi)) 998 999 1000hput(table,name,value) == 1001 if null name then systemError() 1002 HPUT(table,name,value) 1003 1004--============================================================================ 1005-- Dead Code (for a very odd value of 'dead') 1006--============================================================================ 1007asyTypeJoinPartExport x == 1008 [op,:items] := x 1009 for y in items repeat 1010 y isnt ["->",source,t] => 1011-- sig := ['TYPE, op, asyTypeUnit y] 1012-- converts constants to nullary functions (this code isn't dead) 1013 sig := ['SIGNATURE, op, [asyTypeUnit y]] 1014 $opStack := [[sig,:$predlist],:$opStack] 1015 s := 1016 source is ['Comma,:s] => [asyTypeUnit z for z in s] 1017 [asyTypeUnit source] 1018 t := asyTypeUnit t 1019 sig := 1020 null t => ['SIGNATURE,op,s] 1021 ['SIGNATURE,op,[t,:s]] 1022 $opStack := [[sig,:$predlist],:$opStack] 1023 1024--============================================================================ 1025-- Code to create opDead Code 1026--============================================================================ 1027asyTypeJoinStack r == 1028 al := [[[x while r is [[x, :q],:s] and p = q and (r := s; true)],:p] 1029 while r is [[.,:p],:.]] 1030 result := "append"/[fn for [y,:p] in al] where fn == 1031 p => [['IF,asyTypeMakePred p,:y]] 1032 y 1033 result 1034 1035asyTypeMakePred [p,:u] == 1036 while u is [q,:u] repeat p := quickAnd(q,p) 1037 p 1038