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 33)package "BOOT" 34 35--% Various lispy things 36 37MKQ(X) == 38 NUMBERP(X) => X 39 ['QUOTE, X] 40 41INTERNL1(a, b) == INTERN(CONCAT(a, b)) 42 43$GENNO := 0 44 45GENVAR() == 46 INTERNL1('"$", STRINGIMAGE($GENNO := $GENNO + 1)) 47 48contained_eq(x, y) == 49 ATOM(y) => EQ(x, y) 50 contained_eq(x, first(y)) or contained_eq(x, rest(y)) 51 52contained_equal(x, y) == 53 x = y => true 54 ATOM(y) => false 55 contained_equal(x, first(y)) or contained_equal(x, rest(y)) 56 57CONTAINED(x, y) == 58 SYMBOLP(x) => contained_eq(x, y) 59 contained_equal(x, y) 60 61ELEMN(l, n, def_val) == 62 for i in 1..(n - 1) repeat 63 NULL(l) => return def_val 64 l := rest(l) 65 NULL(l) => def_val 66 first(l) 67 68LISTOFATOMS1(l, rl) == 69 NULL(l) => rl 70 ATOM(l) => CONS(l, rl) 71 rl := LISTOFATOMS1(first(l), rl) 72 LISTOFATOMS1(rest(l), rl) 73 74LISTOFATOMS(l) == NREVERSE(LISTOFATOMS1(l, [])) 75 76Identity x == x 77 78length1? l == PAIRP l and not PAIRP QCDR l 79 80length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l 81 82pairList(u,v) == [[x,:y] for x in u for y in v] 83 84concatenateStringList(l) == 85 ll := 0 86 for s in l repeat ll := ll + LENGTH(s) 87 result := MAKE_-STRING(ll) 88 ll := 0 89 for s in l repeat 90 replaceString(result, s, ll) 91 ll := ll + LENGTH(s) 92 result 93 94GETL(op, prop) == op and SYMBOLP(op) and GET(op, prop) 95 96GETALIST(alist,prop) == CDR assoc(prop,alist) 97 98PUTALIST(alist,prop,val) == 99 null alist => [[prop,:val]] 100 pair := assoc(prop,alist) => 101 CDR pair = val => alist 102 -- else we fall over Lucid's read-only storage feature again 103 QRPLACD(pair,val) 104 alist 105 QRPLACD(LASTNODE alist,[[prop,:val]]) 106 alist 107 108REMALIST(alist,prop) == 109 null alist => alist 110 alist is [[ =prop,:.],:r] => 111 null r => NIL 112 QRPLACA(alist,CAR r) 113 QRPLACD(alist,CDR r) 114 alist 115 null rest alist => alist 116 l := alist 117 ok := true 118 while ok repeat 119 [.,[p,:.],:r] := l 120 p = prop => 121 ok := NIL 122 QRPLACD(l,r) 123 if null (l := QCDR l) or null rest l then ok := NIL 124 alist 125 126--% association list functions 127 128deleteAssoc(x,y) == 129 y is [[a,:.],:y'] => 130 a=x => deleteAssoc(x,y') 131 [first y,:deleteAssoc(x,y')] 132 y 133 134insertWOC(x,y) == 135 null y => [x] 136 (fn(x,y); y) where fn(x,y is [h,:t]) == 137 x=h => nil 138 null t => 139 RPLACD(y,[h,:t]) 140 RPLACA(y,x) 141 fn(x,t) 142 143--% Miscellaneous Functions for Working with Strings 144 145fillerSpaces(n, charPart) == 146 n <= 0 => '"" 147 make_full_CVEC(n, charPart) 148 149centerString(text,width,fillchar) == 150 wid := entryWidth text 151 wid >= width => text 152 f := DIVIDE(width - wid,2) 153 fill1 := "" 154 for i in 1..(f.0) repeat 155 fill1 := STRCONC(fillchar,fill1) 156 fill2:= fill1 157 if f.1 ~= 0 then fill1 := STRCONC(fillchar,fill1) 158 [fill1,text,fill2] 159 160stringPrefix?(pref,str) == 161 -- sees if the first #pref letters of str are pref 162 -- replaces STRINGPREFIXP 163 null (STRINGP(pref) and STRINGP(str)) => NIL 164 (lp := QCSIZE pref) = 0 => true 165 lp > QCSIZE str => NIL 166 ok := true 167 i := 0 168 while ok and (i < lp) repeat 169 not EQL(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL 170 i := i + 1 171 ok 172 173dropLeadingBlanks str == 174 str := object2String str 175 l := QCSIZE str 176 nb := NIL 177 i := 0 178 while (i < l) and not nb repeat 179 if SCHAR(str,i) ~= SCHAR('" ",0) then nb := i 180 else i := i + 1 181 nb = 0 => str 182 nb => SUBSTRING(str,nb,NIL) 183 '"" 184 185concat(:l) == concatList l 186 187concatList [x,:y] == 188 null y => x 189 null x => concatList y 190 concat1(x,concatList y) 191 192concat1(x,y) == 193 null x => y 194 atom x => (null y => x; atom y => [x,y]; [x,:y]) 195 null y => x 196 atom y => [:x,y] 197 [:x,:y] 198 199--% Miscellaneous 200 201freeOfSharpVars x == 202 atom x => not isSharpVarWithNum x 203 freeOfSharpVars first x and freeOfSharpVars rest x 204 205listOfSharpVars x == 206 atom x => (isSharpVarWithNum x => LIST x; nil) 207 union(listOfSharpVars first x,listOfSharpVars rest x) 208 209listOfPatternIds x == 210 isPatternVar x => [x] 211 atom x => nil 212 x is ['QUOTE,:.] => nil 213 UNIONQ(listOfPatternIds first x,listOfPatternIds rest x) 214 215isPatternVar v == 216 -- a pattern variable consists of a star followed by a star or digit(s) 217 IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10 218 _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true 219 220removeZeroOne x == 221 -- replace all occurrences of (Zero) and (One) with 222 -- 0 and 1 223 x = $Zero => 0 224 x = $One => 1 225 atom x => x 226 [removeZeroOne first x,:removeZeroOne rest x] 227 228removeZeroOneDestructively t == 229 -- replace all occurrences of (Zero) and (One) with 230 -- 0 and 1 destructively 231 t = $Zero => 0 232 t = $One => 1 233 atom t => t 234 RPLNODE(t,removeZeroOneDestructively first t, 235 removeZeroOneDestructively rest t) 236 237--% Inplace Merge Sort for Lists 238-- MBM April/88 239 240-- listSort(pred,list) or listSort(pred,list,key) 241-- the pred function is a boolean valued function defining the ordering 242-- the key function extracts the key from an item for comparison by pred 243 244listSort(pred,list,:optional) == 245 NOT functionp pred => error "listSort: first arg must be a function" 246 NOT LISTP list => error "listSort: second argument must be a list" 247 NULL optional => mergeSort(pred,function Identity,list,LENGTH list) 248 key := CAR optional 249 NOT functionp key => error "listSort: last arg must be a function" 250 mergeSort(pred,key,list,LENGTH list) 251 252-- non-destructive merge sort using NOT GGREATERP as predicate 253MSORT list == listSort(function GLESSEQP, COPY_-LIST list) 254 255-- destructive merge sort using NOT GGREATERP as predicate 256NMSORT list == listSort(function GLESSEQP, list) 257 258-- non-destructive merge sort using ?ORDER as predicate 259orderList l == listSort(function _?ORDER, COPY_-LIST l) 260 261mergeInPlace(f,g,p,q) == 262 -- merge the two sorted lists p and q 263 if NULL p then return p 264 if NULL q then return q 265 if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q)) 266 then (r := t := p; p := QCDR p) 267 else (r := t := q; q := QCDR q) 268 while not NULL p and not NULL q repeat 269 if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q)) 270 then (QRPLACD(t,p); t := p; p := QCDR p) 271 else (QRPLACD(t,q); t := q; q := QCDR q) 272 if NULL p then QRPLACD(t,q) else QRPLACD(t,p) 273 r 274 275mergeSort(f,g,p,n) == 276 if eql_SI(n, 2) and 277 FUNCALL(f, FUNCALL(g, QCADR p), FUNCALL(g, QCAR p)) then 278 t := p 279 p := QCDR p 280 QRPLACD(p,t) 281 QRPLACD(t,NIL) 282 if less_SI(n, 3) then return p 283 -- split the list p into p and q of equal length 284 l := quo_SI(n, 2) 285 t := p 286 for i in 1..l-1 repeat t := QCDR t 287 q := rest t 288 QRPLACD(t,NIL) 289 p := mergeSort(f,g,p,l) 290 q := mergeSort(f, g, q, sub_SI(n, l)) 291 mergeInPlace(f,g,p,q) 292 293--% Throwing with glorious highlighting (maybe) 294 295throw_to_reader() == THROW('SPAD_READER, nil) 296 297spadThrow() == 298 if $interpOnly and $mapName then 299 putHist($mapName,'localModemap, nil, $e) 300 $BreakMode = 'throw_reader => throw_to_reader() 301 handleLispBreakLoop($BreakMode) 302 303spadThrowBrightly x == 304 sayBrightly x 305 spadThrow() 306 307--% Type Formatting Without Abbreviation 308 309formatUnabbreviatedSig sig == 310 null sig => ["() -> ()"] 311 [target,:args] := sig 312 target := formatUnabbreviated target 313 null args => ['"() -> ",:target] 314 null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target] 315 args := formatUnabbreviatedTuple args 316 ['"(",:args,'") -> ",:target] 317 318formatUnabbreviatedTuple t == 319 -- t is a list of types 320 null t => t 321 atom t => [t] 322 t0 := formatUnabbreviated QCAR t 323 null rest t => t0 324 [:t0,'",",:formatUnabbreviatedTuple QCDR t] 325 326formatUnabbreviated t == 327 atom t => 328 [t] 329 null t => 330 ['"()"] 331 t is [p,sel,arg] and p in '(_: ":") => 332 [sel,'": ",:formatUnabbreviated arg] 333 t is ['Union,:args] => 334 ['Union,'"(",:formatUnabbreviatedTuple args,'")"] 335 t is ['Mapping,:args] => 336 formatUnabbreviatedSig args 337 t is ['Record,:args] => 338 ['Record,'"(",:formatUnabbreviatedTuple args,'")"] 339 t is [arg] => 340 t 341 t is [arg,arg1] => 342 [arg,'" ",:formatUnabbreviated arg1] 343 t is [arg,:args] => 344 [arg,'"(",:formatUnabbreviatedTuple args,'")"] 345 t 346 347sublisNQ(al,e) == 348 atom al => e 349 fn(al,e) where fn(al,e) == 350 atom e => 351 for x in al repeat 352 EQ(first x,e) => return (e := rest x) 353 e 354 EQ(a := first e,'QUOTE) => e 355 u := fn(al,a) 356 v := fn(al,rest e) 357 EQ(a,u) and EQ(rest e,v) => e 358 [u,:v] 359 360opOf x == 361 atom x => x 362 first x 363 364getProplist(x,E) == 365 not atom x => getProplist(first x,E) 366 u:= search(x,E) => u 367 (pl:=search(x,$CategoryFrame)) => 368 pl 369 370search(x,e is [curEnv,:tailEnv]) == 371 tailEnv => 372 BREAK() 373 searchCurrentEnv(x,curEnv) 374 375searchCurrentEnv(x,currentEnv) == 376 for contour in currentEnv repeat 377 if u:= ASSQ(x,contour) then return (signal:= u) 378 IFCDR signal 379 380augProplist(proplist,prop,val) == 381 $InteractiveMode => augProplistInteractive(proplist,prop,val) 382 while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist' 383 val=(u:= LASSOC(prop,proplist)) => proplist 384 null val => 385 null u => proplist 386 DELLASOS(prop,proplist) 387 [[prop,:val],:proplist] 388 389augProplistOf(var,prop,val,e) == 390 proplist:= getProplist(var,e) 391 semchkProplist(var,proplist,prop,val) 392 augProplist(proplist,prop,val) 393 394semchkProplist(x,proplist,prop,val) == 395 prop="isLiteral" => 396 LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x 397 MEMQ(prop,'(mode value)) => 398 LASSOC("isLiteral",proplist) => warnLiteral x 399 400DEFPARAMETER($envHashTable, nil) 401 402addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == 403 EQ(proplist,getProplist(var,e)) => e 404 if $envHashTable then 405 for u in proplist repeat 406 HPUT($envHashTable, [var, CAR u], true) 407 $InteractiveMode => addBindingInteractive(var,proplist,e) 408 if curContour is [[ =var,:.],:.] then curContour:= rest curContour 409 --Previous line should save some space 410 [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] 411 412position(x,l) == 413 posn(x,l,0) where 414 posn(x,l,n) == 415 null l => -1 416 x=first l => n 417 posn(x,rest l,n+1) 418 419insert(x,y) == 420 member(x,y) => y 421 [x,:y] 422 423after(u,v) == 424 r:= u 425 for x in u for y in v repeat r:= rest r 426 r 427 428 429$blank := char ('_ ) 430 431trimString s == 432 leftTrim rightTrim s 433 434leftTrim s == 435 k := MAXINDEX s 436 k < 0 => s 437 s.0 = $blank => 438 for i in 0..k while s.i = $blank repeat (j := i) 439 SUBSTRING(s,j + 1,nil) 440 s 441 442rightTrim s == -- assumed a non-empty string 443 k := MAXINDEX s 444 k < 0 => s 445 s.k = $blank => 446 for i in k..0 by -1 while s.i = $blank repeat (j := i) 447 SUBSTRING(s,0,j) 448 s 449 450pp x == 451 PRETTYPRINT x 452 nil 453 454quickAnd(a,b) == 455 a = true => b 456 b = true => a 457 a = false or b = false => false 458 simpBool ['AND,a,b] 459 460quickOr(a,b) == 461 a = true or b = true => true 462 b = false => a 463 a = false => b 464 simpCatPredicate simpBool ['OR,a,b] 465 466intern x == 467 STRINGP x => 468 DIGITP x.0 => string2Integer x 469 INTERN x 470 x 471 472-- variables used by browser 473 474$htHash := MAKE_HASHTABLE('EQUAL) 475$glossHash := MAKE_HASHTABLE('EQUAL) 476$lispHash := MAKE_HASHTABLE('EQUAL) 477$sysHash := MAKE_HASHTABLE('EQUAL) 478$htSystemCommands := '( 479 (boot . development) clear display (fin . development) edit help 480 frame history load quit read set show synonym system 481 trace what ) 482$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root 483$outStream := nil 484$recheckingFlag := false --see transformAndRecheckComments 485$exposeFlag := false --if true, messages go to $outStream 486$exposeFlagHeading := false --see htcheck.boot 487$checkingXmptex? := false --see htcheck.boot 488$exposeDocHeading:= nil --see htcheck.boot 489$charPlus := char '_+ 490$charBlank:= (char '_ ) 491$charLbrace:= char '_{ 492$charRbrace:= char '_} 493$charBack := char '_\ 494$charDash := char '_- 495 496$charTab := CODE_-CHAR(9) 497$charNewline := CODE_-CHAR(10) 498$charFauxNewline := CODE_-CHAR(25) 499$stringNewline := PNAME CODE_-CHAR(10) 500$stringFauxNewline := PNAME CODE_-CHAR(25) 501 502$charExclusions := [char 'a, char 'A] 503$charQuote := char '_' 504$charSemiColon := char '_; 505$charComma := char '_, 506$charPeriod := char '_. 507$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]] 508$charEscapeList:= [char '_%,char '_#,$charBack] 509$charIdentifierEndings := [char '__, char '_!, char '_?] 510$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%] 511$charDelimiters := [$charBlank, char '_(, char '_), $charBack] 512$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s") 513$HTmacs := [ 514 ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"], 515 ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"], 516 ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"], 517 ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"], 518 ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"], 519 ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]] 520 521$HTlinks := '( 522 "\downlink" 523 "\menulink" 524 "\menudownlink" 525 "\menuwindowlink" 526 "\menumemolink") 527 528$HTlisplinks := '( 529 "\lispdownlink" 530 "\menulispdownlink" 531 "\menulispwindowlink" 532 "\menulispmemolink" 533 "\lispwindowlink" 534 "\lispmemolink") 535 536$beginEndList := '( 537 "page" 538 "items" 539 "menu" 540 "scroll" 541 "verbatim" 542 "detail") 543 544isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& 545 546-- from i-util 547 548--% Utility Functions Used Only by the Interpreter 549 550-- A wrapped value represents something that need not be evaluated 551-- when code is generated. This includes objects from domains or things 552-- that just happed to evaluate to themselves. Typically generated 553-- lisp code is unwrapped. 554 555wrap x == 556 isWrapped x => x 557 ['WRAPPED,:x] 558 559isWrapped x == x is ['WRAPPED,:.] or NUMBERP x or FLOATP x or STRINGP x 560 561unwrap x == 562 NUMBERP x or FLOATP x or STRINGP x => x 563 x is ["WRAPPED",:y] => y 564 x 565 566wrapped2Quote x == 567 x is ["WRAPPED",:y] => MKQ y 568 x 569 570quote2Wrapped x == 571 x is ['QUOTE,y] => wrap y 572 x 573 574removeQuote x == 575 x is ["QUOTE",y] => y 576 x 577 578--% The function for making prompts 579 580spadPrompt() == 581 SAY '" FriCAS" 582 sayNewLine() 583 584princPrompt() == 585 ioHook("startPrompt") 586 PRINC MKPROMPT() 587 ioHook("endOfPrompt") 588 589MKPROMPT() == 590 $inputPromptType = 'none => '"" 591 $inputPromptType = 'plain => '"-> " 592 $inputPromptType = 'step => 593 STRCONC('"(",STRINGIMAGE $IOindex,'") -> ") 594 $inputPromptType = 'frame => 595 STRCONC(STRINGIMAGE $interpreterFrameName, 596 '" (",STRINGIMAGE $IOindex,'") -> ") 597 STRCONC(STRINGIMAGE $interpreterFrameName, 598 '" [", SUBSTRING(CURRENTTIME(),8,NIL),'"] [", 599 STRINGIMAGE $IOindex, '"] -> ") 600 601--% Miscellaneous 602 603-- formerly in clammed.boot 604 605isSubDomain(d1,d2) == 606 -- d1 and d2 are different domains 607 subDomainList := '(Integer NonNegativeInteger PositiveInteger) 608 ATOM d1 or ATOM d2 => nil 609 l := MEMQ(first d2, subDomainList) => 610 MEMQ(first d1, rest l) 611 nil 612 613-- functions used at run-time which were formerly in the compiler files 614 615Undef(:u) == 616 u':= last u 617 [[domain,slot],op,sig]:= u' 618 domain':=eval mkEvalable domain 619 not EQ(first ELT(domain', slot), Undef) => 620 -- OK - the function is now defined 621 [:u'',.]:=u 622 if $reportBottomUpFlag then 623 sayMessage concat ['" Retrospective determination of slot",'%b, 624 slot,'%d,'"of",'%b,:prefix2String domain,'%d] 625 APPLY(first ELT(domain', slot), [:u'', rest ELT(domain', slot)]) 626 throwKeyedMsg("S2IF0008",[formatOpSignature(op,sig),domain]) 627 628TruthP x == 629 --True if x is a predicate that's always true 630 x is nil => nil 631 x=true => true 632 x is ['QUOTE,:.] => true 633 nil 634