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-- This file contains the BOOT code for the FriCAS system command 35-- and synonym processing facility. The code for )trace is in the file 36-- TRACE BOOT. The list of system commands is $SYSCOMMANDS which is 37-- initialized in SETQ LISP. 38 39--% Utility Variable Initializations 40 41DEFPARAMETER($compileRecurrence, true) 42 43DEFPARAMETER($SYSCOMMANDS, [first x for x in $systemCommands]) 44 45 46DEFPARAMETER($whatOptions, '( _ 47 operations _ 48 categories _ 49 domains _ 50 packages _ 51 commands _ 52 synonyms _ 53 things _ 54 )) 55 56DEFPARAMETER($clearOptions, '( _ 57 modes _ 58 operations _ 59 properties _ 60 types _ 61 values _ 62 )) 63 64DEFPARAMETER($displayOptions, '( _ 65 abbreviations _ 66 all _ 67 macros _ 68 modes _ 69 names _ 70 operations _ 71 properties _ 72 types _ 73 values _ 74 )) 75 76DEFPARAMETER($countAssoc, '( (cache countCache) )) 77 78--% Top level system command 79 80initializeSystemCommands() == 81 l := $systemCommands 82 $SYSCOMMANDS := NIL 83 while l repeat 84 $SYSCOMMANDS := CONS(CAAR l, $SYSCOMMANDS) 85 l := rest l 86 $SYSCOMMANDS := NREVERSE $SYSCOMMANDS 87 88systemCommand [[op,:argl],:options] == 89 $options: local:= options 90 $e:local := $CategoryFrame 91 fun := selectOptionLC(op,$SYSCOMMANDS,'commandError) 92 argl and (argl.0 = '_?) and fun ~= 'synonym => 93 helpSpad2Cmd [fun] 94 fun := selectOption(fun,commandsForUserLevel $systemCommands, 95 'commandUserLevelError) 96 FUNCALL(fun, argl) 97 98commandsForUserLevel l == --[a for [a,:b] in l | satisfiesUserLevel(a)] 99 c := nil 100 for [a,:b] in l repeat 101 satisfiesUserLevel b => c := [a,:c] 102 reverse c 103 104synonymsForUserLevel l == 105 -- l is a list of synonyms, and this returns a sublist of applicable 106 -- synonyms at the current user level. 107 $UserLevel = 'development => l 108 nl := NIL 109 for syn in reverse l repeat 110 cmd := STRING2ID_N(rest(syn), 1) 111 null selectOptionLC(cmd,commandsForUserLevel 112 $systemCommands,NIL) => nil 113 nl := [syn,:nl] 114 nl 115 116satisfiesUserLevel x == 117 x = 'interpreter => true 118 $UserLevel = 'interpreter => false 119 x = 'compiler => true 120 $UserLevel = 'compiler => false 121 true 122 123unAbbreviateKeyword x == 124 x' :=selectOptionLC(x,$SYSCOMMANDS,'commandErrorIfAmbiguous) 125 if not x' then 126 x' := 'system 127 SETQ(LINE, CONCAT('")system ", SUBSTRING(LINE, 1, #LINE-1))) 128 $currentLine := LINE 129 selectOption(x',commandsForUserLevel $systemCommands, 130 'commandUserLevelError) 131 132hasOption(al,opt) == 133 optPname:= PNAME opt 134 found := NIL 135 for pair in al while not found repeat 136 stringPrefix?(PNAME first pair, optPname) => found := pair 137 found 138 139selectOptionLC(x,l,errorFunction) == 140 selectOption(DOWNCASE object2Identifier x,l,errorFunction) 141 142selectOption(x,l,errorFunction) == 143 member(x,l) => x --exact spellings are always OK 144 null IDENTP x => 145 errorFunction => FUNCALL(errorFunction,x,u) 146 nil 147 u := [y for y in l | stringPrefix?(PNAME x,PNAME y)] 148 u is [y] => y 149 errorFunction => FUNCALL(errorFunction,x,u) 150 nil 151 152terminateSystemCommand() == 153 FRESH_-LINE() 154 TOK := 'END_UNIT 155 throw_to_reader() 156 157commandUserLevelError(x,u) == userLevelErrorMessage("command",x,u) 158 159optionUserLevelError(x,u) == userLevelErrorMessage("option",x,u) 160 161userLevelErrorMessage(kind,x,u) == 162 null u => 163 sayKeyedMsg("S2IZ0007",[$UserLevel,kind]) 164 terminateSystemCommand() 165 commandAmbiguityError(kind,x,u) 166 167commandError(x,u) == commandErrorMessage("command",x,u) 168 169optionError(x,u) == commandErrorMessage("option",x,u) 170 171commandErrorIfAmbiguous(x, u) == 172 null u => nil 173 commandAmbiguityError("command", x, u) 174 175commandErrorMessage(kind,x,u) == 176 null u => 177 sayKeyedMsg("S2IZ0008",[kind,x]) 178 terminateSystemCommand() 179 commandAmbiguityError(kind,x,u) 180 181commandAmbiguityError(kind,x,u) == 182 sayKeyedMsg("S2IZ0009",[kind,x]) 183 for a in u repeat sayMSG ['" ",:bright a] 184 terminateSystemCommand() 185 186--% Utility for access to original command line 187 188getSystemCommandLine() == 189 p := STRPOS('")",$currentLine,0,NIL) 190 line := if p then SUBSTRING($currentLine,p,NIL) else $currentLine 191 maxIndex:= MAXINDEX line 192 for i in 0..maxIndex while (line.i~=" ") repeat index:= i 193 if index=maxIndex then line := '"" 194 else line := SUBSTRING(line,index+2,nil) 195 line 196 197------------ start of commands ------------------------------------------ 198 199--% )abbreviations 200 201abbreviations l == 202 ioHook("startSysCmd", "abbrev") 203 abbreviationsSpad2Cmd l 204 ioHook("endSysCmd", "abbrev") 205 206abbreviationsSpad2Cmd l == 207 null l => helpSpad2Cmd '(abbreviations) 208 abopts := '(query domain category package remove) 209 210 quiet := nil 211 for [opt] in $options repeat 212 opt := selectOptionLC(opt,'(quiet),'optionError) 213 opt = 'quiet => quiet := true 214 215 l is [opt,:al] => 216 key := opOf first al 217 type := selectOptionLC(opt,abopts,'optionError) 218 type is 'query => 219 null al => listConstructorAbbreviations() 220 constructor := abbreviation?(key) => abbQuery(constructor) 221 abbQuery(key) 222 type is 'remove => 223 DELDATABASE(key,'ABBREVIATION) 224 ODDP SIZE al => sayKeyedMsg("S2IZ0002",[type]) 225 repeat 226 null al => return 'fromLoop 227 [a,b,:al] := al 228 mkUserConstructorAbbreviation(b,a,type) 229 SETDATABASE(b,'ABBREVIATION,a) 230 SETDATABASE(b,'CONSTRUCTORKIND,type) 231 null quiet => 232 sayKeyedMsg("S2IZ0001",[a,type,opOf b]) 233 nil 234 nil 235 236listConstructorAbbreviations() == 237 x := UPCASE queryUserKeyedMsg("S2IZ0056",NIL) 238 MEMQ(STRING2ID_N(x, 1), '(Y YES)) => 239 whatSpad2Cmd '(categories) 240 whatSpad2Cmd '(domains) 241 whatSpad2Cmd '(packages) 242 sayKeyedMsg("S2IZ0057",NIL) 243 244--% )cd 245 246cd(args) == 247 dname := 248 null(args) => 249 TRIM_-DIRECTORY_-NAME(NAMESTRING(USER_-HOMEDIR_-PATHNAME())) 250 first(args) 251 if SYMBOLP(dname) then dname := SYMBOL_-NAME(dname) 252 CHDIR(dname) 253 sayKeyedMsg("S2IZ0070", [GET_-CURRENT_-DIRECTORY()]) 254 255--% )clear 256 257clear l == clearSpad2Cmd l 258 259clearSpad2Cmd l == 260 -- new version which changes the environment and updates history 261 $clearExcept: local := nil 262 if $options then $clearExcept := 263 "and"/[selectOptionLC(opt,'(except),'optionError) = 264 'except for [opt,:.] in $options] 265 null l => 266 optList:= "append"/[['%l,'" ",x] for x in $clearOptions] 267 sayKeyedMsg("S2IZ0010",[optList]) 268 arg := selectOptionLC(first l,'(all completely scaches),NIL) 269 arg = 'all => clearCmdAll() 270 arg = 'completely => clearCmdCompletely() 271 arg = 'scaches => clear_sorted_caches() 272 $clearExcept => clearCmdExcept(l) 273 clearCmdParts(l) 274 updateCurrentInterpreterFrame() 275 276clearCmdCompletely() == 277 clearCmdAll() 278 $localExposureData := COPY_-SEQ $localExposureDataDefault 279 sayKeyedMsg("S2IZ0013",NIL) 280 clearClams() 281 clearConstructorCaches() 282 sayKeyedMsg("S2IZ0014",NIL) 283 RECLAIM() 284 sayKeyedMsg("S2IZ0015",NIL) 285 NIL 286 287clearCmdAll() == 288 clear_sorted_caches() 289 ------undo special variables------ 290 $frameRecord := nil 291 $previousBindings := nil 292 untraceMapSubNames $trace_names 293 $InteractiveFrame := LIST LIST NIL 294 resetInCoreHist() 295 if $useInternalHistoryTable 296 then $internalHistoryTable := NIL 297 else deleteFile histFileName() 298 if not null $IOindex then $IOindex := 1 299 updateCurrentInterpreterFrame() 300 $currentLine := '")clear all" --restored 3/94; needed for undo (RDJ) 301 clearMacroTable() 302 if $frameMessages then sayKeyedMsg("S2IZ0011",[$interpreterFrameName]) 303 else sayKeyedMsg("S2IZ0012",NIL) 304 305clearCmdExcept(l is [opt,:vl]) == 306 --clears elements of vl of all options EXCEPT opt 307 for option in $clearOptions | 308 not stringPrefix?(object2String opt,object2String option) 309 repeat clearCmdParts [option,:vl] 310 311clearCmdParts(l is [opt,:vl]) == 312 -- clears the bindings indicated by opt of all variables in vl 313 314 option:= selectOptionLC(opt,$clearOptions,'optionError) 315 option:= INTERN PNAME option 316 317 -- the option can be plural but the key in the alist is sometimes 318 -- singular 319 320 option := 321 option = 'types => 'mode 322 option = 'modes => 'mode 323 option = 'values => 'value 324 option 325 326 null vl => sayKeyedMsg("S2IZ0055",NIL) 327 pmacs := getParserMacroNames() 328 imacs := getInterpMacroNames() 329 if vl='(all) then 330 vl := ASSOCLEFT CAAR $InteractiveFrame 331 vl := REMDUP(append(vl, pmacs)) 332 $e : local := $InteractiveFrame 333 for x in vl repeat 334 clearDependencies(x) 335 if option='properties and x in pmacs then clearParserMacro(x) 336 if option='properties and x in imacs and not (x in pmacs) then 337 sayMessage ['" You cannot clear the definition of the system-defined macro ", 338 fixObjectForPrinting x,"."] 339 p1 := assoc(x,CAAR $InteractiveFrame) => 340 option='properties => 341 if isMap x then 342 (lm := get(x,'localModemap,$InteractiveFrame)) => 343 PAIRP lm => untraceMapSubNames [CADAR lm] 344 NIL 345 for p2 in rest p1 repeat 346 prop := first p2 347 recordOldValue(x, prop, rest p2) 348 recordNewValue(x, prop, NIL) 349 SETF(CAAR $InteractiveFrame,deleteAssoc(x,CAAR $InteractiveFrame)) 350 p2 := assoc(option, rest p1) => 351 recordOldValue(x, option, rest p2) 352 recordNewValue(x,option,NIL) 353 RPLACD(p2,NIL) 354 nil 355 356--% )close 357 358queryClients () == 359 -- Returns the number of active scratchpad clients 360 sockSendInt($SessionManager, $QueryClients) 361 sockGetInt $SessionManager 362 363 364close args == 365 quiet:local:= false 366 null $SpadServer => 367 throwKeyedMsg("S2IZ0071", []) 368 numClients := queryClients() 369 numClients > 1 => 370 sockSendInt($SessionManager, $CloseClient) 371 sockSendInt($SessionManager, $currentFrameNum) 372 closeInterpreterFrame(NIL) 373 for [opt,:.] in $options repeat 374 fullopt := selectOptionLC(opt, '(quiet), 'optionError) 375 fullopt = 'quiet => 376 quiet:=true 377 quiet => 378 sockSendInt($SessionManager, $CloseClient) 379 sockSendInt($SessionManager, $currentFrameNum) 380 closeInterpreterFrame(NIL) 381 x := UPCASE queryUserKeyedMsg("S2IZ0072", nil) 382 MEMQ(STRING2ID_N(x, 1), '(YES Y)) => 383 QUIT() 384 nil 385 386--% )compile 387 388compile args == 389 $newConlist: local := nil --reset by compDefineLisplib and astran 390 null args and null $options and null($edit_file) => 391 helpSpad2Cmd '(compile) 392 if null args then args := [$edit_file] 393 394 -- first see if the user has explicitly specified the compiler 395 -- to use. 396 397 optlist := '(new old constructor) 398 haveNew := nil 399 haveOld := nil 400 for opt in $options while not (haveNew and haveOld) repeat 401 [optname,:optargs] := opt 402 fullopt := selectOptionLC(optname,optlist,nil) 403 fullopt = 'new => haveNew := true 404 fullopt = 'constructor => haveOld := true 405 fullopt = 'old => haveOld := true 406 407 haveNew and haveOld => throwKeyedMsg("S2IZ0081", nil) 408 409 af := pathname args 410 aft := pathnameType af 411 412 haveNew or (aft = '"as") => 413 not (af1 := find_file(af, '(as))) => 414 throwKeyedMsg("S2IL0003",[NAMESTRING af]) 415 compileAsharpCmd [af1] 416 haveOld or (aft = '"spad") => 417 not (af1 := find_file(af, '(spad))) => 418 throwKeyedMsg("S2IL0003",[NAMESTRING af]) 419 compileSpad2Cmd [af1] 420 aft = '"lsp" => 421 not (af1 := find_file(af, '(lsp))) => 422 throwKeyedMsg("S2IL0003",[NAMESTRING af]) 423 compileAsharpLispCmd [af1] 424 aft = '"NRLIB" => 425 not (af1 := find_file(af, '(NRLIB))) => 426 throwKeyedMsg("S2IL0003",[NAMESTRING af]) 427 compileSpadLispCmd [af1] 428 aft = '"ao" => 429 not (af1 := find_file(af, '(ao))) => 430 throwKeyedMsg("S2IL0003",[NAMESTRING af]) 431 compileAsharpCmd [af1] 432 aft = '"al" => -- archive library of .ao files 433 not (af1 := find_file(af, '(al))) => 434 throwKeyedMsg("S2IL0003",[NAMESTRING af]) 435 compileAsharpArchiveCmd [af1] 436 437 -- see if we something with the appropriate file extension 438 -- lying around 439 440 af1 := find_file(af, '(as spad ao asy)) 441 442 af1 and pathnameType(af1) = '"as" => compileAsharpCmd [af1] 443 af1 and pathnameType(af1) = '"ao" => compileAsharpCmd [af1] 444 af1 and pathnameType(af1) = '"spad" => compileSpad2Cmd [af1] 445 af1 and pathnameType(af1) = '"asy" => compileAsharpArchiveCmd [af1] 446 447 throwKeyedMsg("S2IZ0039", nil) 448 449compileAsharpCmd args == 450 compileAsharpCmd1 args 451 terminateSystemCommand() 452 spadPrompt() 453 454compileAsharpCmd1 args == 455 -- Assume we entered from the "compile" function, so args ~= nil 456 -- and is a file with file extension .as or .ao 457 458 path := pathname args 459 pathType := pathnameType path 460 (pathType ~= '"as") and (pathType ~= '"ao") => throwKeyedMsg("S2IZ0083", nil) 461 not PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) 462 463 $edit_file := path 464 465 optList := '( _ 466 new _ 467 old _ 468 onlyargs _ 469 moreargs _ 470 quiet _ 471 nolispcompile _ 472 noquiet _ 473 library _ 474 nolibrary _ 475 ) 476 477 beQuiet := false -- be verbose here 478 doLibrary := true -- so a )library after compilation 479 doCompileLisp := true -- do compile generated lisp code 480 481 moreArgs := NIL 482 onlyArgs := NIL 483 484 for opt in $options repeat 485 [optname,:optargs] := opt 486 fullopt := selectOptionLC(optname,optList,nil) 487 488 fullopt = 'new => nil 489 fullopt = 'old => error "Internal error: compileAsharpCmd got )old" 490 fullopt = 'quiet => beQuiet := true 491 fullopt = 'noquiet => beQuiet := false 492 493 fullopt = 'nolispcompile => doCompileLisp := false 494 495 fullopt = 'moreargs => moreArgs := optargs 496 fullopt = 'onlyargs => onlyArgs := optargs 497 498 fullopt = 'library => doLibrary := true 499 fullopt = 'nolibrary => doLibrary := false 500 501 throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) 502 503 tempArgs := 504 pathType = '"ao" => 505 -- want to strip out -Fao 506 (p := STRPOS('"-Fao", $asharpCmdlineFlags, 0, NIL)) => 507 p = 0 => SUBSTRING($asharpCmdlineFlags, 5, NIL) 508 STRCONC(SUBSTRING($asharpCmdlineFlags, 0, p), '" ", 509 SUBSTRING($asharpCmdlineFlags, p+5, NIL)) 510 $asharpCmdlineFlags 511 $asharpCmdlineFlags 512 513 asharpArgs := 514 onlyArgs => 515 s := "" 516 for a in onlyArgs repeat 517 s := STRCONC(s, '" ", object2String a) 518 s 519 moreArgs => 520 s := tempArgs 521 for a in moreArgs repeat 522 s := STRCONC(s, '" ", object2String a) 523 s 524 tempArgs 525 526 if not beQuiet then sayKeyedMsg("S2IZ0038A",[namestring args, asharpArgs]) 527 528 command := 529 STRCONC(getEnv('"ALDOR_COMPILER"),_ 530 '" ", asharpArgs, '" ", namestring args) 531 rc := OBEY command 532 533 if (rc = 0) and doCompileLisp then 534 lsp := fnameMake('".", pathnameName args, '"lsp") 535 if fnameReadable?(lsp) then 536 if not beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) 537 compileFileQuietly(lsp) 538 else 539 sayKeyedMsg("S2IL0003", [namestring lsp]) 540 541 if rc = 0 and doLibrary then 542 -- do we need to worry about where the compilation output went? 543 if not beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) 544 withAsharpCmd [ pathnameName path ] 545 else if not beQuiet then 546 sayKeyedMsg("S2IZ0084", nil) 547 548 extendLocalLibdb $newConlist 549 550compileAsharpArchiveCmd args == 551 -- Assume we entered from the "compile" function, so args ~= nil 552 -- and is a file with file extension .al. We also assume that 553 -- the name is fully qualified. 554 555 path := pathname args 556 (FILE_-KIND namestring args) ~= 1 => 557 throwKeyedMsg("S2IL0003",[namestring args]) 558 559 -- here is the plan: 560 -- 1. extract the file name and try to make a directory based 561 -- on that name. 562 -- 2. cd to that directory and ar x the .al file 563 -- 3. for each .ao file that shows up, compile it 564 -- 4. delete the generated .ao files 565 566 -- First try to make the directory in the current directory 567 568 dir := fnameMake('".", pathnameName path, '"axldir") 569 isDir := FILE_-KIND namestring dir 570 isDir = 0 => 571 throwKeyedMsg("S2IL0027",[namestring dir, namestring args]) 572 573 if isDir ~= 1 then 574 cmd := STRCONC('"mkdir ", namestring dir) 575 rc := OBEY cmd 576 rc ~= 0 => throwKeyedMsg("S2IL0027",[namestring dir, namestring args]) 577 578 curDir := GET_-CURRENT_-DIRECTORY() 579 580 -- cd to that directory and try to unarchive the .al file 581 582 cd [ namestring dir ] 583 584 cmd := STRCONC( '"ar x ", namestring path ) 585 rc := OBEY cmd 586 rc ~= 0 => 587 cd [ namestring curDir ] 588 throwKeyedMsg("S2IL0028",[namestring dir, namestring args]) 589 590 -- Look for .ao files 591 592 asos := DIRECTORY '"*.ao" 593 null asos => 594 cd [ namestring curDir ] 595 throwKeyedMsg("S2IL0029",[namestring dir, namestring args]) 596 597 -- Compile the .ao files 598 599 for aso in asos repeat 600 compileAsharpCmd1 [ namestring aso ] 601 602 -- Reset the current directory 603 604 cd [ namestring curDir ] 605 606 terminateSystemCommand() 607 spadPrompt() 608 609compileAsharpLispCmd args == 610 -- Assume we entered from the "compile" function, so args ~= nil 611 -- and is a file with file extension .lsp 612 613 path := pathname args 614 not PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) 615 616 optList := '( _ 617 quiet _ 618 noquiet _ 619 library _ 620 nolibrary _ 621 ) 622 623 beQuiet := false -- be verbose here 624 doLibrary := true -- so a )library after compilation 625 626 for opt in $options repeat 627 [optname,:optargs] := opt 628 fullopt := selectOptionLC(optname,optList,nil) 629 630 fullopt = 'quiet => beQuiet := true 631 fullopt = 'noquiet => beQuiet := false 632 633 fullopt = 'library => doLibrary := true 634 fullopt = 'nolibrary => doLibrary := false 635 636 throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) 637 638 lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path) 639 if fnameReadable?(lsp) then 640 if not beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) 641 compileFileQuietly(lsp) 642 else 643 sayKeyedMsg("S2IL0003", [namestring lsp]) 644 645 if doLibrary then 646 -- do we need to worry about where the compilation output went? 647 if not beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) 648 withAsharpCmd [ pathnameName path ] 649 else if not beQuiet then 650 sayKeyedMsg("S2IZ0084", nil) 651 terminateSystemCommand() 652 spadPrompt() 653 654compileSpadLispCmd args == 655 -- Assume we entered from the "compile" function, so args ~= nil 656 -- and is a file with file extension .NRLIB 657 658 libname := first args 659 basename := PATHNAME_-NAME(libname) 660 path := pathname fnameMake(libname, basename, '"lsp") 661 not PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) 662 663 optList := '( _ 664 quiet _ 665 noquiet _ 666 library _ 667 nolibrary _ 668 ) 669 670 beQuiet := false -- be verbose here 671 doLibrary := true -- so a )library after compilation 672 673 for opt in $options repeat 674 [optname,:optargs] := opt 675 fullopt := selectOptionLC(optname,optList,nil) 676 677 fullopt = 'quiet => beQuiet := true 678 fullopt = 'noquiet => beQuiet := false 679 680 fullopt = 'library => doLibrary := true 681 fullopt = 'nolibrary => doLibrary := false 682 683 throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) 684 685 lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path) 686 if fnameReadable?(lsp) then 687 if not beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) 688 compile_lib_file lsp 689 else 690 sayKeyedMsg("S2IL0003", [namestring lsp]) 691 692 if doLibrary then 693 -- do we need to worry about where the compilation output went? 694 if not beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) 695 LOCALDATABASE([pathnameName(libname)], []) 696 else if not beQuiet then 697 sayKeyedMsg("S2IZ0084", nil) 698 terminateSystemCommand() 699 spadPrompt() 700 701withAsharpCmd args == 702 $options: local := nil 703 LOCALDATABASE(args, $options) 704 705--% )copyright -- display copyright notice 706 707summary l == 708 OBEY STRCONC ('"cat ",getEnv('"FRICAS"),'"/lib/summary") 709copyright () == 710 OBEY STRCONC ('"cat ",getEnv('"FRICAS"),'"/lib/copyright") 711 712--% )credits -- display credit list 713 714credits() == 715 for i in CREDITS repeat 716 PRINC(i) 717 TERPRI() 718 719--% )display 720 721display l == 722 ioHook("startSysCmd", "display") 723 UNWIND_-PROTECT(displaySpad2Cmd l, ioHook("endSysCmd", "display")) 724 725displaySpad2Cmd l == 726 $e: local := $EmptyEnvironment 727 l is [opt,:vl] and opt ~= "?" => 728 option := selectOptionLC(opt,$displayOptions,'optionError) => 729 730 -- the option may be given in the plural but the property in 731 -- the alist is sometimes singular 732 733 option := 734 option = 'all => 735 l := ['properties] 736 'properties 737 (option = 'modes) or (option = 'types) => 738 l := ['type, :vl] 739 'type 740 option = 'values => 741 l := ['value, :vl] 742 'value 743 option 744 745 option = 'abbreviations => 746 null vl => listConstructorAbbreviations() 747 for v in vl repeat 748 constructor := abbreviation?(opOf v) => abbQuery(constructor) 749 abbQuery(opOf v) 750 751 option = 'operations => displayOperations vl 752 option = 'macros => displayMacros vl 753 option = 'names => displayWorkspaceNames() 754 displayProperties(option,l) 755 optList:= [:['%l,'" ",x] for x in $displayOptions] 756 msg := [:bright '" )display",'"keyword arguments are", 757 :bright optList,'%l,'" or abbreviations thereof."] 758 sayMessage msg 759 760displayMacros names == 761 imacs := getInterpMacroNames() 762 pmacs := getParserMacroNames() 763 macros := 764 null names => APPEND (imacs, pmacs) 765 names 766 macros := REMDUP macros 767 768 null macros => sayBrightly '" There are no FriCAS macros." 769 770 -- first do user defined ones 771 772 first := true 773 for macro in macros repeat 774 macro in pmacs => 775 if first then 776 sayBrightly ['%l,'"User-defined macros:"] 777 first := NIL 778 displayParserMacro macro 779 macro in imacs => 'iterate 780 sayBrightly ([" ",'%b, macro, '%d, " is not a known FriCAS macro."]) 781 782 -- now system ones 783 784 first := true 785 for macro in macros repeat 786 macro in imacs => 787 macro in pmacs => 'iterate 788 if first then 789 sayBrightly ['%l,'"System-defined macros:"] 790 first := NIL 791 displayMacro macro 792 macro in pmacs => 'iterate 793 NIL 794 795getParserMacroNames() == 796 REMDUP [first mac for mac in getParserMacros()] 797 798clearParserMacro(macro) == 799 -- first see if it is one 800 not IFCDR assoc(macro, ($pfMacros)) => NIL 801 $pfMacros := REMALIST($pfMacros, macro) 802 803displayMacro name == 804 m := isInterpMacro name 805 null m => 806 sayBrightly ['" ",:bright name,'"is not an interpreter macro."] 807 op := STRCONC('"macro ", object2String name) 808 [args,:body] := m 809 args := 810 null args => nil 811 null rest args => first args 812 ['Tuple,:args] 813 mathprint outputMapTran(op, ['SPADMAP, [args, :body]]) 814 815displayWorkspaceNames() == 816 imacs := getInterpMacroNames() 817 pmacs := getParserMacroNames() 818 sayMessage '"Names of User-Defined Objects in the Workspace:" 819 names := MSORT append(getWorkspaceNames(),pmacs) 820 if null names 821 then sayBrightly " * None *" 822 else sayAsManyPerLineAsPossible [object2String x for x in names] 823 imacs := SETDIFFERENCE(imacs,pmacs) 824 if imacs then 825 sayMessage '"Names of System-Defined Objects in the Workspace:" 826 sayAsManyPerLineAsPossible [object2String x for x in imacs] 827 828 829getWorkspaceNames() == 830 NMSORT [n for [n,:.] in CAAR $InteractiveFrame | 831 (n ~= "--macros--" and n~= "--flags--")] 832 833displayOperations l == 834 null l => 835 x := UPCASE queryUserKeyedMsg("S2IZ0058",NIL) 836 if MEMQ(STRING2ID_N(x, 1), '(Y YES)) 837 then for op in allOperations() repeat reportOpSymbol op 838 else sayKeyedMsg("S2IZ0059",NIL) 839 nil 840 for op in l repeat reportOpSymbol op 841 842interpFunctionDepAlists() == 843 $e : local := $InteractiveFrame 844 deps := getFlag "$dependencies" 845 $dependentAlist := [[NIL,:NIL]] 846 $dependeeAlist := [[NIL,:NIL]] 847 for [dependee,dependent] in deps repeat 848 $dependentAlist := PUTALIST($dependentAlist,dependee, 849 CONS(dependent,GETALIST($dependentAlist,dependee))) 850 $dependeeAlist := PUTALIST($dependeeAlist,dependent, 851 CONS(dependee,GETALIST($dependeeAlist,dependent))) 852 853fixObjectForPrinting(v) == 854 v' := object2Identifier v 855 EQ(v',"%") => '"\%" 856 v' in $msgdbPrims => STRCONC('"\",PNAME v') 857 v 858 859displayProperties(option,l) == 860 $dependentAlist : local := nil 861 $dependeeAlist : local := nil 862 [opt,:vl]:= (l or ['properties]) 863 imacs := getInterpMacroNames() 864 pmacs := getParserMacroNames() 865 macros := REMDUP append(imacs, pmacs) 866 if vl is ['all] or null vl then 867 vl := MSORT append(getWorkspaceNames(),macros) 868 if $frameMessages then sayKeyedMsg("S2IZ0065",[$interpreterFrameName]) 869 null vl => 870 null $frameMessages => sayKeyedMsg("S2IZ0066",NIL) 871 sayKeyedMsg("S2IZ0067",[$interpreterFrameName]) 872 interpFunctionDepAlists() 873 for v in vl repeat 874 isInternalMapName(v) => 'iterate 875 pl := getIProplist(v) 876 option = 'flags => getAndSay(v,"flags") 877 option = 'value => displayValue(v,getI(v,'value),nil) 878 option = 'condition => displayCondition(v,getI(v,"condition"),nil) 879 option = 'mode => displayMode(v,getI(v,'mode),nil) 880 option = 'type => displayType(v,getI(v,'value),nil) 881 option = 'properties => 882 v = "--flags--" => nil 883 pl is [['cacheInfo,:.],:.] => nil 884 v1 := fixObjectForPrinting(v) 885 sayMSG ['"Properties of",:bright prefix2String v1,'":"] 886 null pl => 887 v in pmacs => 888 sayMSG '" This is a user-defined macro." 889 displayParserMacro v 890 isInterpMacro v => 891 sayMSG '" This is a system-defined macro." 892 displayMacro v 893 sayMSG '" none" 894 propsSeen:= nil 895 for [prop,:val] in pl | not MEMQ(prop,propsSeen) and val repeat 896 prop in '(alias generatedCode mapBody localVars) => 897 nil 898 prop = 'condition => 899 displayCondition(prop,val,true) 900 prop = 'recursive => 901 sayMSG '" This is recursive." 902 prop = 'isInterpreterFunction => 903 sayMSG '" This is an interpreter function." 904 sayFunctionDeps v 905 prop = 'isInterpreterRule => 906 sayMSG '" This is an interpreter rule." 907 sayFunctionDeps v 908 prop = 'localModemap => 909 displayModemap(v,val,true) 910 prop = 'mode => 911 displayMode(prop,val,true) 912 prop = 'value => 913 val => displayValue(v,val,true) 914 sayMSG ['" ",prop,'": ",val] 915 propsSeen:= [prop,:propsSeen] 916 sayKeyedMsg("S2IZ0068",[option]) 917 terminateSystemCommand() 918 919sayFunctionDeps x == 920 if dependents := GETALIST($dependentAlist,x) then 921 null rest dependents => 922 sayMSG ['" The following function or rule ", 923 '"depends on this:",:bright first dependents] 924 sayMSG 925 '" The following functions or rules depend on this:" 926 msg := ["%b",'" "] 927 for y in dependents repeat msg := ['" ",y,:msg] 928 sayMSG [:nreverse msg,"%d"] 929 if dependees := GETALIST($dependeeAlist,x) then 930 null rest dependees => 931 sayMSG ['" This depends on the following function ", 932 '"or rule:",:bright first dependees] 933 sayMSG 934 '" This depends on the following functions or rules:" 935 msg := ["%b",'" "] 936 for y in dependees repeat msg := ['" ",y,:msg] 937 sayMSG [:nreverse msg,"%d"] 938 939displayModemap(v,val,giveVariableIfNil) == 940 for mm in val repeat g(v,mm,giveVariableIfNil) where 941 g(v,mm,giveVariableIfNil) == 942 [[local,:signature],fn,:.]:= mm 943 local='interpOnly => nil 944 varPart:= (giveVariableIfNil => nil; ['" of",:bright v]) 945 prefix:= [" Compiled function type",:varPart,": "] 946 sayBrightly concat(prefix,formatSignature signature) 947 948displayMode(v,mode,giveVariableIfNil) == 949 null mode => nil 950 varPart:= (giveVariableIfNil => nil; [" of",:bright fixObjectForPrinting v]) 951 sayBrightly concat(" Declared type or mode", 952 varPart,": ",prefix2String mode) 953 954displayCondition(v,condition,giveVariableIfNil) == 955 varPart:= (giveVariableIfNil => nil; [" of",:bright v]) 956 condPart:= condition or 'true 957 sayBrightly concat(" condition",varPart,": ",pred2English condPart) 958 959getAndSay(v,prop) == 960 val:= getI(v,prop) => sayMSG [" ",val,'%l] 961 sayMSG [" none",'%l] 962 963displayType(op, u, omitVariableNameIfTrue) == 964 null u => 965 sayMSG ['" Type of value of ", 966 fixObjectForPrinting PNAME op, '": (none)"] 967 type := prefix2String objMode(u) 968 if ATOM type then type := [type] 969 sayMSG concat ['" Type of value of ", fixObjectForPrinting PNAME op, 970 '": ", :type] 971 NIL 972 973displayValue(op, u, omitVariableNameIfTrue) == 974 null u => sayMSG [" Value of ", fixObjectForPrinting PNAME op, 975 '": (none)"] 976 expr := objValUnwrap(u) 977 expr is [op1, :.] and (op1 = 'SPADMAP) => 978 displayRule(op, expr) 979 objMode(u) = $EmptyMode => BREAK() 980 label:= 981 omitVariableNameIfTrue => 982 rhs := '"): " 983 '"Value (has type " 984 rhs := '": " 985 STRCONC('"Value of ", PNAME op, '": ") 986 labmode := prefix2String objMode(u) 987 if ATOM labmode then labmode := [labmode] 988 GETDATABASE(expr,'CONSTRUCTORKIND) = 'domain => 989 sayMSG concat('" ",label,labmode,rhs,form2String expr) 990 mathprint ['CONCAT,label,:labmode,rhs, 991 outputFormat(expr,objMode(u))] 992 NIL 993 994--% )edit 995 996edit l == editSpad2Cmd l 997 998editSpad2Cmd l == 999 l:= 1000 null l => $edit_file 1001 first l 1002 l := pathname l 1003 oldDir := pathnameDirectory l 1004 fileTypes := 1005 pathnameType l => [pathnameType l] 1006 $UserLevel = 'interpreter => '("input" "INPUT" "spad" "SPAD") 1007 $UserLevel = 'compiler => '("input" "INPUT" "spad" "SPAD") 1008 '("input" "INPUT" "spad" "SPAD" "boot" "BOOT" "lisp" "LISP") 1009 ll := 1010 oldDir = '"" => pathname find_file(pathnameName l, fileTypes) 1011 l 1012 l := pathname ll 1013 $edit_file := l 1014 rc := editFile l 1015 rc 1016 1017--% )help 1018 1019help l == helpSpad2Cmd l 1020 1021helpSpad2Cmd args == 1022 -- try to use new stuff first 1023 if newHelpSpad2Cmd(args) then return nil 1024 1025 sayBrightly "Available help topics for system commands are:" 1026 sayBrightly "" 1027 sayBrightly " boot cd clear close compile display" 1028 sayBrightly " edit fin frame help history library" 1029 sayBrightly " lisp load ltrace pquit quit read" 1030 sayBrightly " set show spool synonym system trace" 1031 sayBrightly " undo what" 1032 sayBrightly "" 1033 sayBrightly "Issue _")help help_" for more information about the help command." 1034 1035 nil 1036 1037newHelpSpad2Cmd args == 1038 if null args then args := ["?"] 1039 # args > 1 => 1040 sayKeyedMsg("S2IZ0026",NIL) 1041 true 1042 sarg := PNAME first args 1043 if sarg = '"?" then args := ['nullargs] 1044 else if sarg = '"%" then args := ['history] 1045 else if sarg = '"%%" then args := ['history] 1046 arg := selectOptionLC(first args,$SYSCOMMANDS,nil) 1047 if null arg then arg := first args 1048 1049 -- see if new help file exists 1050 1051 narg := PNAME arg 1052 null(helpFile := make_input_filename([narg, 'HELPSPAD])) => nil 1053 1054 $useFullScreenHelp => 1055 OBEY STRCONC('"$FRICAS/lib/SPADEDIT ",namestring helpFile) 1056 true 1057 1058 filestream := MAKE_INSTREAM(helpFile) 1059 repeat 1060 line := read_line(filestream) 1061 NULL line => 1062 SHUT filestream 1063 return true 1064 SAY line 1065 true 1066 1067--% 1068--% )frame 1069--% 1070 1071$frameRecord := nil --Initial setting for frame record 1072$previousBindings := nil 1073 1074frame l == frameSpad2Cmd l 1075 1076frameName(frame) == first frame 1077 1078frameNames() == [frameName f for f in $interpreterFrameRing] 1079 1080frameEnvironment fname == 1081 -- extracts the environment portion of a frame 1082 -- if fname is not a valid frame name then the empty environment 1083 -- is returned 1084 fname = frameName first $interpreterFrameRing => $InteractiveFrame 1085 ifr := rest $interpreterFrameRing 1086 e := LIST LIST NIL 1087 while ifr repeat 1088 [f,:ifr] := ifr 1089 if fname = frameName f then 1090 e := CADR f 1091 ifr := NIL 1092 e 1093 1094frameSpad2Cmd args == 1095 frameArgs := '(drop import last names new next) 1096 $options => throwKeyedMsg("S2IZ0016",['")frame"]) 1097 null(args) => helpSpad2Cmd ['frame] 1098 arg := selectOptionLC(first args,frameArgs,'optionError) 1099 args := rest args 1100 if args is [a] then args := a 1101 if ATOM args then args := object2Identifier args 1102 arg = 'drop => 1103 args and PAIRP(args) => throwKeyedMsg("S2IZ0017",[args]) 1104 closeInterpreterFrame(args) 1105 arg = 'import => importFromFrame args 1106 arg = 'last => previousInterpreterFrame() 1107 arg = 'names => displayFrameNames() 1108 arg = 'new => 1109 args and PAIRP(args) => throwKeyedMsg("S2IZ0017",[args]) 1110 addNewInterpreterFrame(args) 1111 arg = 'next => nextInterpreterFrame() 1112 1113 NIL 1114 1115addNewInterpreterFrame(name) == 1116 null name => throwKeyedMsg("S2IZ0018",NIL) 1117 updateCurrentInterpreterFrame() 1118 -- see if we already have one by that name 1119 for f in $interpreterFrameRing repeat 1120 name = frameName(f) => throwKeyedMsg("S2IZ0019",[name]) 1121 initHistList() 1122 $interpreterFrameRing := CONS(emptyInterpreterFrame(name), 1123 $interpreterFrameRing) 1124 updateFromCurrentInterpreterFrame() 1125 erase_lib([histFileName()]) 1126 1127emptyInterpreterFrame(name) == 1128 LIST(name, -- frame name 1129 LIST LIST NIL, -- environment 1130 1, -- $IOindex 1131 $HiFiAccess, -- $HiFiAccess 1132 $HistList, -- $HistList 1133 $HistListLen, -- $HistListLen 1134 $HistListAct, -- $HistListAct 1135 $HistRecord, -- $HistRecord 1136 NIL, -- $internalHistoryTable 1137 COPY_-SEQ $localExposureDataDefault -- $localExposureData 1138 ) 1139 1140closeInterpreterFrame(name) == 1141 -- if name = NIL then it means the current frame 1142 null rest $interpreterFrameRing => 1143 name and (name ~= $interpreterFrameName) => 1144 throwKeyedMsg("S2IZ0020",[$interpreterFrameName]) 1145 throwKeyedMsg("S2IZ0021",NIL) 1146 if null name then $interpreterFrameRing := rest $interpreterFrameRing 1147 else -- find the frame 1148 found := nil 1149 ifr := NIL 1150 for f in $interpreterFrameRing repeat 1151 found or (name ~= frameName(f)) => ifr := CONS(f,ifr) 1152 found := true 1153 not found => throwKeyedMsg("S2IZ0022",[name]) 1154 erase_lib([makeHistFileName(name)]) 1155 $interpreterFrameRing := nreverse ifr 1156 updateFromCurrentInterpreterFrame() 1157 1158previousInterpreterFrame() == 1159 updateCurrentInterpreterFrame() 1160 null rest $interpreterFrameRing => NIL -- nothing to do 1161 [:b,l] := $interpreterFrameRing 1162 $interpreterFrameRing := NCONC2([l],b) 1163 updateFromCurrentInterpreterFrame() 1164 1165nextInterpreterFrame() == 1166 updateCurrentInterpreterFrame() 1167 null rest $interpreterFrameRing => NIL -- nothing to do 1168 $interpreterFrameRing := 1169 NCONC2(rest $interpreterFrameRing,[first $interpreterFrameRing]) 1170 updateFromCurrentInterpreterFrame() 1171 1172 1173createCurrentInterpreterFrame() == 1174 LIST($interpreterFrameName, -- frame name 1175 $InteractiveFrame, -- environment 1176 $IOindex, -- $IOindex 1177 $HiFiAccess, -- $HiFiAccess 1178 $HistList, -- $HistList 1179 $HistListLen, -- $HistListLen 1180 $HistListAct, -- $HistListAct 1181 $HistRecord, -- $HistRecord 1182 $internalHistoryTable, -- $internalHistoryTable 1183 $localExposureData -- $localExposureData 1184 ) 1185 1186 1187updateFromCurrentInterpreterFrame() == 1188 [$interpreterFrameName, _ 1189 $InteractiveFrame, _ 1190 $IOindex, _ 1191 $HiFiAccess, _ 1192 $HistList, _ 1193 $HistListLen, _ 1194 $HistListAct, _ 1195 $HistRecord, _ 1196 $internalHistoryTable, _ 1197 $localExposureData _ 1198 ] := first $interpreterFrameRing 1199 if $frameMessages then 1200 sayMessage ['" Current interpreter frame is called",:bright 1201 $interpreterFrameName] 1202 NIL 1203 1204 1205updateCurrentInterpreterFrame() == 1206 RPLACA($interpreterFrameRing,createCurrentInterpreterFrame()) 1207 updateFromCurrentInterpreterFrame() 1208 NIL 1209 1210initializeInterpreterFrameRing() == 1211 $interpreterFrameName := 'initial 1212 $interpreterFrameRing := [emptyInterpreterFrame($interpreterFrameName)] 1213 updateFromCurrentInterpreterFrame() 1214 NIL 1215 1216 1217changeToNamedInterpreterFrame(name) == 1218 updateCurrentInterpreterFrame() 1219 frame := findFrameInRing(name) 1220 null frame => NIL 1221 $interpreterFrameRing := [frame,:NREMOVE($interpreterFrameRing, frame)] 1222 updateFromCurrentInterpreterFrame() 1223 1224makeInitialModemapFrame() == COPY $InitialModemapFrame 1225 1226findFrameInRing(name) == 1227 val := NIL 1228 for frame in $interpreterFrameRing repeat 1229 first frame = name => 1230 val := frame 1231 return frame 1232 val 1233 1234displayFrameNames() == 1235 fs := "append"/[ ['%l,'" ",:bright frameName f] for f in 1236 $interpreterFrameRing] 1237 sayKeyedMsg("S2IZ0024",[fs]) 1238 1239importFromFrame args == 1240 -- args should have the form [frameName,:varNames] 1241 if args and atom args then args := [args] 1242 null args => throwKeyedMsg("S2IZ0073",NIL) 1243 [fname,:args] := args 1244 not member(fname,frameNames()) => 1245 throwKeyedMsg("S2IZ0074",[fname]) 1246 fname = frameName first $interpreterFrameRing => 1247 throwKeyedMsg("S2IZ0075",NIL) 1248 fenv := frameEnvironment fname 1249 null args => 1250 x := UPCASE queryUserKeyedMsg("S2IZ0076",[fname]) 1251 MEMQ(STRING2ID_N(x, 1), '(Y YES)) => 1252 vars := NIL 1253 for [v,:props] in CAAR fenv repeat 1254 v = "--macros" => 1255 for [m,:.] in props repeat vars := cons(m,vars) 1256 vars := cons(v,vars) 1257 importFromFrame [fname,:vars] 1258 sayKeyedMsg("S2IZ0077",[fname]) 1259 for v in args repeat 1260 plist := GETALIST(CAAR fenv,v) 1261 plist => 1262 -- remove anything with the same name in the current frame 1263 clearCmdParts ['propert,v] 1264 for [prop,:val] in plist repeat 1265 putHist(v,prop,val,$InteractiveFrame) 1266 (m := get("--macros--",v,fenv)) => 1267 putHist("--macros--",v,m,$InteractiveFrame) 1268 sayKeyedMsg("S2IZ0079",[v,fname]) 1269 sayKeyedMsg("S2IZ0078",[fname]) 1270 1271 1272 1273--% )history 1274 1275++ vm/370 filename type component 1276DEFPARAMETER($historyFileType, 'axh) 1277 1278++ vm/370 filename name component 1279DEFPARAMETER($oldHistoryFileName, 'last) 1280DEFPARAMETER($internalHistoryTable, NIL) 1281 1282++ t means keep history in core 1283DEFPARAMETER($useInternalHistoryTable, true) 1284 1285history l == 1286 l or null $options => sayKeyedMsg("S2IH0006",NIL) 1287 historySpad2Cmd() 1288 1289 1290makeHistFileName(fname) == 1291 makePathname(fname,$historyFileType) 1292 1293oldHistFileName() == 1294 makeHistFileName($oldHistoryFileName) 1295 1296DEFPARAMETER($curHistFileName, nil) 1297 1298histFileName() == 1299 $curHistFileName => makeHistFileName($curHistFileName) 1300 makeHistFileName($interpreterFrameName) 1301 1302 1303histInputFileName(fn) == 1304 null fn => 1305 makePathname($interpreterFrameName,'INPUT) 1306 makePathname(fn,'INPUT) 1307 1308 1309initHist() == 1310 $useInternalHistoryTable => initHistList() 1311 oldFile := oldHistFileName() 1312 newFile := histFileName() 1313 -- see if history directory is writable 1314 histFileErase oldFile 1315 if make_input_filename(newFile) then replace_lib(newFile, oldFile) 1316 $HiFiAccess:= 'T 1317 initHistList() 1318 1319initHistList() == 1320 -- creates $HistList as a circular list of length $HistListLen 1321 -- and $HistRecord 1322 $HistListLen:= 20 1323 $HistList:= LIST NIL 1324 li:= $HistList 1325 for i in 1..$HistListLen repeat li:= CONS(NIL,li) 1326 RPLACD($HistList,li) 1327 $HistListAct:= 0 1328 $HistRecord:= NIL 1329 1330historySpad2Cmd() == 1331 -- history is a system command which can call resetInCoreHist 1332 -- and changeHistListLen, and restore last session 1333 histOptions:= 1334 '(on off yes no change reset restore write save show file memory) 1335 opts:= [ [selectOptionLC(opt,histOptions,'optionError),:optargs] 1336 for [opt,:optargs] in $options] 1337 for [opt,:optargs] in opts repeat 1338 opt in '(on yes) => 1339 $HiFiAccess => sayKeyedMsg("S2IH0007",NIL) 1340 $IOindex = 1 => -- haven't done anything yet 1341 $HiFiAccess:= 'T 1342 initHistList() 1343 sayKeyedMsg("S2IH0008",NIL) 1344 x := UPCASE queryUserKeyedMsg("S2IH0009",NIL) 1345 MEMQ(STRING2ID_N(x, 1), '(Y YES)) => 1346 histFileErase histFileName() 1347 $HiFiAccess:= 'T 1348 $options := nil 1349 clearSpad2Cmd '(all) 1350 sayKeyedMsg("S2IH0008",NIL) 1351 initHistList() 1352 sayKeyedMsg("S2IH0010",NIL) 1353 opt in '(off no) => 1354 null $HiFiAccess => sayKeyedMsg("S2IH0011",NIL) 1355 $HiFiAccess:= NIL 1356 disableHist() 1357 sayKeyedMsg("S2IH0012",NIL) 1358 opt = 'file => setHistoryCore NIL 1359 opt = 'memory => setHistoryCore true 1360 opt = 'reset => resetInCoreHist() 1361 opt = 'save => saveHistory optargs 1362 opt = 'show => showHistory optargs 1363 opt = 'change => changeHistListLen first optargs 1364 opt = 'restore => restoreHistory optargs 1365 opt = 'write => writeInputLines(optargs,1) 1366 'done 1367 1368 1369setHistoryCore inCore == 1370 inCore = $useInternalHistoryTable => 1371 sayKeyedMsg((inCore => "S2IH0030"; "S2IH0029"),NIL) 1372 not $HiFiAccess => 1373 $useInternalHistoryTable := inCore 1374 inCore => sayKeyedMsg("S2IH0032",NIL) 1375 sayKeyedMsg("S2IH0031",NIL) 1376 inCore => 1377 $internalHistoryTable := NIL 1378 if $IOindex ~= 0 then 1379 -- actually put something in there 1380 l := LENGTH RKEYIDS histFileName() 1381 for i in 1..l repeat 1382 vec:= UNWIND_-PROTECT(readHiFi(i),disableHist()) 1383 $internalHistoryTable := CONS([i,:vec],$internalHistoryTable) 1384 histFileErase histFileName() 1385 $useInternalHistoryTable := true 1386 sayKeyedMsg("S2IH0032",NIL) 1387 $HiFiAccess:= 'NIL 1388 histFileErase histFileName() 1389 str := rMkOstream(histFileName()) 1390 for [n,:rec] in reverse $internalHistoryTable repeat 1391 SPADRWRITE(object2Identifier n,rec,str) 1392 RSHUT str 1393 $HiFiAccess:= 'T 1394 $internalHistoryTable := NIL 1395 $useInternalHistoryTable := NIL 1396 sayKeyedMsg("S2IH0031",NIL) 1397 1398 1399writeInputLines(fn,initial) == 1400 -- writes all input lines into file histInputFileName() 1401 not $HiFiAccess => sayKeyedMsg("S2IH0013",NIL) -- history not on 1402 null fn => 1403 throwKeyedMsg("S2IH0038", nil) -- missing file name 1404 maxn := 72 1405 breakChars := [" ","+"] 1406 for i in initial..$IOindex - 1 repeat 1407 vecl := first readHiFi i 1408 if STRINGP vecl then vecl := [vecl] 1409 for vec in vecl repeat 1410 n := SIZE vec 1411 while n > maxn repeat 1412 -- search backwards for a blank 1413 done := nil 1414 for j in 1..maxn while not done repeat 1415 k := 1 + maxn - j 1416 MEMQ(vec.k,breakChars) => 1417 svec := STRCONC(SUBSTRING(vec,0,k+1),UNDERBAR) 1418 lineList := [svec,:lineList] 1419 done := true 1420 vec := SUBSTRING(vec,k+1,NIL) 1421 n := SIZE vec 1422 -- in case we can't find a breaking point 1423 if not done then n := 0 1424 lineList := [vec,:lineList] 1425 file := histInputFileName(fn) 1426 maybe_delete_file(file) 1427 inp := MAKE_OUTSTREAM(file) 1428 for x in removeUndoLines NREVERSE lineList repeat WRITE_-LINE(x,inp) 1429 -- see file "undo" for definition of removeUndoLines 1430 if fn ~= 'redo then sayKeyedMsg("S2IH0014",[namestring file]) 1431 SHUT inp 1432 NIL 1433 1434 1435resetInCoreHist() == 1436 -- removes all pointers from $HistList 1437 $HistListAct:= 0 1438 for i in 1..$HistListLen repeat 1439 $HistList := rest $HistList 1440 RPLACA($HistList,NIL) 1441 1442changeHistListLen(n) == 1443 -- changes the length of $HistList. n must be nonnegative 1444 NULL INTEGERP n => sayKeyedMsg("S2IH0015",[n]) 1445 dif:= n-$HistListLen 1446 $HistListLen:= n 1447 l := rest $HistList 1448 if dif > 0 then 1449 for i in 1..dif repeat l:= CONS(NIL,l) 1450 if dif < 0 then 1451 for i in 1..-dif repeat l := rest l 1452 if $HistListAct > n then $HistListAct:= n 1453 RPLACD($HistList,l) 1454 'done 1455 1456updateHist() == 1457 -- updates the history file and calls updateInCoreHist 1458 null $IOindex => nil 1459 startTimingProcess 'history 1460 updateInCoreHist() 1461 if $HiFiAccess then 1462 UNWIND_-PROTECT(writeHiFi(),disableHist()) 1463 $HistRecord:= NIL 1464 $IOindex:= $IOindex+1 1465 updateCurrentInterpreterFrame() 1466 $currentLine := nil 1467 stopTimingProcess 'history 1468 1469updateInCoreHist() == 1470 -- updates $HistList and $IOindex 1471 $HistList := rest($HistList) 1472 RPLACA($HistList,NIL) 1473 if $HistListAct < $HistListLen then $HistListAct:= $HistListAct+1 1474 1475putHist(x,prop,val,e) == 1476 -- records new value to $HistRecord and old value to $HistList 1477 -- then put is called with e 1478 if not (x='%) then recordOldValue(x,prop,get(x,prop,e)) 1479 if $HiFiAccess then recordNewValue(x,prop,val) 1480 putIntSymTab(x,prop,val,e) 1481 1482histFileErase(file) == erase_lib([file]) 1483 1484recordNewValue(x,prop,val) == 1485 startTimingProcess 'history 1486 recordNewValue0(x,prop,val) 1487 stopTimingProcess 'history 1488 1489recordNewValue0(x,prop,val) == 1490 -- writes (prop . val) into $HistRecord 1491 -- updateHist writes this stuff out into the history file 1492 p1:= ASSQ(x,$HistRecord) => 1493 p2 := ASSQ(prop, rest p1) => 1494 RPLACD(p2,val) 1495 RPLACD(p1, CONS(CONS(prop, val), rest p1)) 1496 p:= CONS(x,list CONS(prop,val)) 1497 $HistRecord:= CONS(p,$HistRecord) 1498 1499recordOldValue(x,prop,val) == 1500 startTimingProcess 'history 1501 recordOldValue0(x,prop,val) 1502 stopTimingProcess 'history 1503 1504recordOldValue0(x,prop,val) == 1505 -- writes (prop . val) into $HistList 1506 p1 := ASSQ(x, first $HistList) => 1507 not ASSQ(prop, rest p1) => 1508 RPLACD(p1, CONS(CONS(prop, val), rest p1)) 1509 p:= CONS(x,list CONS(prop,val)) 1510 RPLACA($HistList, CONS(p, first $HistList)) 1511 1512undoInCore(n) == 1513 -- undoes the last n>0 steps using $HistList 1514 -- resets $InteractiveFrame 1515 li:= $HistList 1516 for i in n..$HistListLen repeat li := rest li 1517 undoChanges(li) 1518 n:= $IOindex-n-1 1519 n>0 and 1520 $HiFiAccess => 1521 vec := rest UNWIND_-PROTECT(readHiFi(n), disableHist()) 1522 val := (p := ASSQ('%, vec)) and (p1 := ASSQ('value, rest p)) and 1523 rest p1 1524 sayKeyedMsg("S2IH0019",[n]) 1525 $InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame) 1526 updateHist() 1527 1528undoChanges(li) == 1529 -- undoes all changes of list 'li' 1530 if not (rest li = $HistList) then undoChanges rest li 1531 for p1 in first li repeat 1532 x := first p1 1533 for p2 in rest p1 repeat 1534 putHist(x, first p2, rest p2, $InteractiveFrame) 1535 1536undoFromFile(n) == 1537 -- makes a clear and redoes all the assignments until step n 1538 for [x,:varl] in CAAR $InteractiveFrame repeat 1539 for p in varl repeat 1540 [prop,:val]:= p 1541 val => 1542 if not (x='%) then recordOldValue(x,prop,val) 1543 if $HiFiAccess then recordNewValue(x,prop,val) 1544 RPLACD(p,NIL) 1545 for i in 1..n repeat 1546 vec := UNWIND_-PROTECT(rest readHiFi(i), disableHist()) 1547 for p1 in vec repeat 1548 x := first p1 1549 for p2 in rest p1 repeat 1550 $InteractiveFrame := putHist(x, first p2, rest p2, $InteractiveFrame) 1551 val := (p := ASSQ('%, vec)) and (p1 := ASSQ('value, rest p)) and rest p1 1552 $InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame) 1553 updateHist() 1554 1555saveHistory(fn) == 1556 $seen : local := MAKE_HASHTABLE('EQ) 1557 not $HiFiAccess => sayKeyedMsg("S2IH0016",NIL) 1558 not $useInternalHistoryTable and 1559 null(make_input_filename(histFileName())) => 1560 sayKeyedMsg("S2IH0022", nil) 1561 null fn => 1562 throwKeyedMsg("S2IH0037", nil) 1563 savefile := makeHistFileName(fn) 1564 inputfile := histInputFileName(fn) 1565 writeInputLines(fn,1) 1566 histFileErase savefile 1567 1568 if $useInternalHistoryTable 1569 then 1570 saveStr := rMkOstream(savefile) 1571 for [n,:rec] in reverse $internalHistoryTable repeat 1572 val := SPADRWRITE0(object2Identifier n,rec,saveStr) 1573 val = 'writifyFailed => 1574 sayKeyedMsg("S2IH0035", [n, inputfile]) -- unable to save step 1575 RSHUT saveStr 1576 sayKeyedMsg("S2IH0018",[namestring(savefile)]) -- saved hist file named 1577 nil 1578 1579restoreHistory(fn) == 1580 -- uses fn $historyFileType to recover an old session 1581 -- if fn = NIL, then use $oldHistoryFileName 1582 if null fn then fn' := $oldHistoryFileName 1583 else if fn is [fn'] and IDENTP(fn') then fn' := fn' 1584 else throwKeyedMsg("S2IH0023",[fn']) 1585 restfile := makeHistFileName(fn') 1586 null(make_input_filename(restfile)) => 1587 sayKeyedMsg("S2IH0024",[namestring(restfile)]) -- no history file 1588 1589 -- if clear is changed to be undoable, this should be a reset-clear 1590 $options: local := nil 1591 clearSpad2Cmd '(all) 1592 oldInternal := $useInternalHistoryTable 1593 restoreHistory2(oldInternal, restfile, fn') 1594 sayKeyedMsg("S2IH0025",[namestring(restfile)]) 1595 clear_sorted_caches() 1596 nil 1597 1598restoreHistory2(oldInternal, restfile, fn) == 1599 $curHistFileName : local := fn 1600 $useInternalHistoryTable : local := nil 1601 if not(oldInternal) then 1602 curfile := histFileName() 1603 histFileErase curfile 1604 copy_file(restfile, curfile) 1605 $curHistFileName := nil 1606 restfile := curfile 1607 1608 l:= LENGTH RKEYIDS restfile 1609 $HiFiAccess:= 'T 1610 if oldInternal then $internalHistoryTable := NIL 1611 for i in 1..l repeat 1612 vec:= UNWIND_-PROTECT(readHiFi(i),disableHist()) 1613 if oldInternal then $internalHistoryTable := 1614 CONS([i,:vec],$internalHistoryTable) 1615 LINE := first vec 1616 for p1 in rest vec repeat 1617 x := first p1 1618 for p2 in rest p1 repeat 1619 $InteractiveFrame := putHist(x, first p2, rest p2, $InteractiveFrame) 1620 updateInCoreHist() 1621 $e := $InteractiveFrame 1622 for [a,:.] in CAAR $InteractiveFrame repeat 1623 get(a,'localModemap,$InteractiveFrame) => 1624 rempropI(a,'localModemap) 1625 rempropI(a,'localVars) 1626 rempropI(a,'mapBody) 1627 $IOindex:= l+1 1628 $useInternalHistoryTable := oldInternal 1629 1630 1631-- the following used to be the show command when that was used to 1632-- show history. 1633showHistory(arg) == 1634 -- arg can be of form 1635 -- NIL show at most last 20 input lines 1636 -- (n) show at most last n input lines 1637 -- (lit) where lit is an abbreviation for 'input or 'both 1638 -- if 'input, same as NIL 1639 -- if 'both, show last 5 input and outputs 1640 -- (n lit) show last n input lines + last n output lines 1641 -- if lit expands to 'both 1642 $evalTimePrint: local:= 0 1643 $printTimeSum: local:= 0 1644 -- ugh!!! these are needed for timedEvaluateStream 1645 -- displays the last n steps, default n=20 1646 not $HiFiAccess => sayKeyedMsg("S2IH0026",['show]) 1647 showInputOrBoth := 'input 1648 n := 20 1649 nset := nil 1650 if arg then 1651 arg1 := first arg 1652 if INTEGERP arg1 then 1653 n := arg1 1654 nset := true 1655 IFCDR arg => arg1 := CADR arg 1656 arg1 := NIL 1657 arg1 => 1658 arg2 := selectOptionLC(arg1,'(input both),nil) 1659 if arg2 1660 then ((showInputOrBoth := arg2) = 'both) and (null nset) => n:= 5 1661 else sayMSG 1662 concat('" ",bright arg1,'"is an invalid argument.") 1663 if n >= $IOindex then n:= $IOindex-1 1664 mini:= $IOindex-n 1665 maxi:= $IOindex-1 1666 showInputOrBoth = 'both => 1667 UNWIND_-PROTECT(showInOut(mini,maxi),setIOindex(maxi+1)) 1668 showInput(mini,maxi) 1669 1670setIOindex(n) == 1671 -- set $IOindex to n 1672 $IOindex:= n 1673 1674showInput(mini,maxi) == 1675 -- displays all input lines from mini to maxi 1676 for ind in mini..maxi repeat 1677 vec:= UNWIND_-PROTECT(readHiFi(ind),disableHist()) 1678 if ind<10 then TAB 2 else if ind<100 then TAB 1 1679 l := first vec 1680 STRINGP l => 1681 sayMSG ['" [", ind, '"] ", first vec] 1682 sayMSG ['" [",ind,'"] " ] 1683 for ln in l repeat 1684 sayMSG ['" ", ln] 1685 1686showInOut(mini,maxi) == 1687 -- displays all steps from mini to maxi 1688 for ind in mini..maxi repeat 1689 vec:= UNWIND_-PROTECT(readHiFi(ind),disableHist()) 1690 sayMSG [first vec] 1691 Alist := ASSQ('%, rest vec) => 1692 triple := rest ASSQ('value, rest Alist) 1693 $IOindex:= ind 1694 spadPrint(objValUnwrap triple,objMode triple) 1695 1696fetchOutput(n) == 1697 -- result is the output of step n 1698 (n = -1) and (val := getI("%",'value)) => val 1699 $HiFiAccess => 1700 n:= 1701 n < 0 => $IOindex+n 1702 n 1703 n >= $IOindex => throwKeyedMsg("S2IH0001",[n]) 1704 n < 1 => throwKeyedMsg("S2IH0002",[n]) 1705 vec:= UNWIND_-PROTECT(readHiFi(n),disableHist()) 1706 Alist := ASSQ('%, rest vec) => 1707 val := rest ASSQ('value, rest Alist) => val 1708 throwKeyedMsg("S2IH0003",[n]) 1709 throwKeyedMsg("S2IH0003",[n]) 1710 throwKeyedMsg("S2IH0004",NIL) 1711 1712readHiFi(n) == 1713 -- reads the file using index n 1714 if $useInternalHistoryTable 1715 then 1716 pair := assoc(n,$internalHistoryTable) 1717 ATOM pair => keyedSystemError("S2IH0034",NIL) 1718 vec := QCDR pair 1719 else 1720 HiFi:= rMkIstream(histFileName()) 1721 vec:= SPADRREAD(object2Identifier n,HiFi) 1722 RSHUT HiFi 1723 vec 1724 1725writeHiFi() == 1726 -- writes the information of the current step out to history file 1727 if $useInternalHistoryTable 1728 then 1729 $internalHistoryTable := CONS([$IOindex,$currentLine,:$HistRecord], 1730 $internalHistoryTable) 1731 else 1732 HiFi:= rMkOstream(histFileName()) 1733 SPADRWRITE(object2Identifier $IOindex, CONS($currentLine,$HistRecord),HiFi) 1734 RSHUT HiFi 1735 1736disableHist() == 1737 -- disables the history mechanism if an error occurred in the protected 1738 -- piece of code 1739 not $HiFiAccess => histFileErase histFileName() 1740 NIL 1741 1742writeHistModesAndValues() == 1743 for [a,:.] in CAAR $InteractiveFrame repeat 1744 x := get(a,'value,$InteractiveFrame) => 1745 putHist(a,'value,x,$InteractiveFrame) 1746 x := get(a,'mode,$InteractiveFrame) => 1747 putHist(a,'mode,x,$InteractiveFrame) 1748 NIL 1749 1750SPADRREAD(vec, stream) == 1751 dewritify rread(vec, stream) 1752 1753--% Lisplib output transformations 1754-- Some types of objects cannot be saved by LISP/VM in lisplibs. 1755-- These functions transform an object to a writable form and back. 1756-- SMW 1757SPADRWRITE(vec, item, stream) == 1758 val := SPADRWRITE0(vec, item, stream) 1759 val = 'writifyFailed => 1760 throwKeyedMsg("S2IH0036", nil) -- cannot save value to file 1761 item 1762 1763SPADRWRITE0(vec, item, stream) == 1764 val := safeWritify item 1765 val = 'writifyFailed => val 1766 rwrite(vec, val, stream) 1767 item 1768 1769safeWritify ob == 1770 CATCH('writifyTag, writify ob) 1771 1772writify ob == 1773 not ScanOrPairVec(function(unwritable?), ob) => ob 1774 $seen : local := MAKE_HASHTABLE('EQ) 1775 $writifyComplained: local := false 1776 1777 writifyInner ob where 1778 writifyInner ob == 1779 null ob => nil 1780 (e := HGET($seen, ob)) => e 1781 1782 PAIRP ob => 1783 qcar := QCAR ob 1784 qcdr := QCDR ob 1785 (qcar = function newGoGet) => 1786 writifyInner replaceGoGetSlot qcdr 1787 (name := spadClosure? ob) => 1788 d := writifyInner qcdr 1789 nob := ['WRITIFIED_!_!, 'SPADCLOSURE, d, name] 1790 HPUT($seen, ob, nob) 1791 HPUT($seen, nob, nob) 1792 nob 1793 (ob is ['LAMBDA_-CLOSURE, ., ., x, :.]) and x => 1794 THROW('writifyTag, 'writifyFailed) 1795 nob := CONS(qcar, qcdr) 1796 HPUT($seen, ob, nob) 1797 HPUT($seen, nob, nob) 1798 qcar := writifyInner qcar 1799 qcdr := writifyInner qcdr 1800 QRPLACA(nob, qcar) 1801 QRPLACD(nob, qcdr) 1802 nob 1803 VECP ob => 1804 isDomainOrPackage ob => 1805 d := mkEvalable devaluate ob 1806 nob := ['WRITIFIED_!_!, 'DEVALUATED, writifyInner d] 1807 HPUT($seen, ob, nob) 1808 HPUT($seen, nob, nob) 1809 nob 1810 n := QVMAXINDEX ob 1811 nob := MAKE_VEC(n + 1) 1812 HPUT($seen, ob, nob) 1813 HPUT($seen, nob, nob) 1814 for i in 0..n repeat 1815 QSETVELT(nob, i, writifyInner QVELT(ob,i)) 1816 nob 1817 GENERAL_ARRAY?(ob) => 1818 dims := ARRAY_-DIMENSIONS(ob) 1819 nob := MAKE_-ARRAY(dims) 1820 HPUT($seen, ob, nob) 1821 HPUT($seen, nob, nob) 1822 n := ARRAY_-TOTAL_-SIZE(ob) 1823 for i in 0..(n - 1) repeat 1824 SETF(ROW_-MAJOR_-AREF(nob, i), 1825 writifyInner(ROW_-MAJOR_-AREF(ob, i))) 1826 nob 1827 is_BVEC(ob) => ob 1828 STRINGP ob => 1829 EQ(ob, $NullStream) => ['WRITIFIED_!_!, 'NULLSTREAM] 1830 EQ(ob, $NonNullStream) => ['WRITIFIED_!_!, 'NONNULLSTREAM] 1831 ob 1832 ARRAYP(ob) => 1833 tt := get_type_tag(ARRAY_-ELEMENT_-TYPE(ob)) 1834 tt => 1835 dims := ARRAY_-DIMENSIONS(ob) 1836 n := ARRAY_-TOTAL_-SIZE(ob) 1837 nv := MAKE_VEC(n) 1838 nob := ['WRITIFIED_!_!, 'TYARR, tt, dims, nv] 1839 HPUT($seen, ob, nob) 1840 HPUT($seen, nob, nob) 1841 for i in 0..(n - 1) repeat 1842 QSETVELT(nv, i, 1843 writifyInner(ROW_-MAJOR_-AREF(ob, i))) 1844 nob 1845 THROW('writifyTag, 'writifyFailed) 1846 SPAD_KERNEL_-P ob => 1847 nob := makeSpadKernel(NIL, NIL, SPAD_KERNEL_-NEST(ob)) 1848 HPUT($seen, ob, nob) 1849 HPUT($seen, nob, nob) 1850 SETF(SPAD_KERNEL_-OP(nob), _ 1851 writifyInner SPAD_KERNEL_-OP(ob)) 1852 SETF(SPAD_KERNEL_-ARG(nob), _ 1853 writifyInner SPAD_KERNEL_-ARG(ob)) 1854 nob 1855 ob = 'WRITIFIED_!_! => 1856 ['WRITIFIED_!_!, 'SELF] 1857 -- In CCL constructors are also compiled functions, so we 1858 -- need this line: 1859 constructor? ob => ob 1860 COMPILED_-FUNCTION_-P ob => 1861 THROW('writifyTag, 'writifyFailed) 1862 HASHTABLEP ob => 1863 nob := ['WRITIFIED_!_!] 1864 HPUT($seen, ob, nob) 1865 HPUT($seen, nob, nob) 1866 keys := HKEYS ob 1867 QRPLACD(nob, 1868 ['HASHTABLE, 1869 HASHTABLE_CLASS(ob), 1870 writifyInner keys, 1871 [writifyInner HGET(ob,k) for k in keys]]) 1872 nob 1873 PLACEP ob => 1874 nob := ['WRITIFIED_!_!, 'PLACE] 1875 HPUT($seen, ob, nob) 1876 HPUT($seen, nob, nob) 1877 nob 1878 -- The next three types cause an error on de-writifying. 1879 -- Create an object of the right shape, nonetheless. 1880 READTABLEP ob => 1881 THROW('writifyTag, 'writifyFailed) 1882 FLOATP ob => 1883 ob = READ_-FROM_-STRING STRINGIMAGE ob => ob 1884 ['WRITIFIED_!_!, 'FLOAT, ob,: 1885 MULTIPLE_-VALUE_-LIST INTEGER_-DECODE_-FLOAT ob] 1886 -- Default case: return the object itself. 1887 ob 1888 1889 1890unwritable? ob == 1891 -- first for speed 1892 PAIRP(ob) => false 1893 EQ(ob, $NullStream) or EQ(ob, $NonNullStream) => true 1894 -- writable arrays 1895 VECP(ob) or GENERAL_ARRAY?(ob) or STRINGP(ob) or is_BVEC(ob) => false 1896 -- other arrays are unwritable 1897 ARRAYP(ob) => true 1898 COMPILED_-FUNCTION_-P ob or HASHTABLEP ob => true 1899 PLACEP ob or READTABLEP ob => true 1900 FLOATP ob => true 1901 false 1902 1903$type_tags := [ 1904 ["U8", ['UNSIGNED_-BYTE, 8]], 1905 ["U16", ['UNSIGNED_-BYTE, 16]], 1906 ["U32", ['UNSIGNED_-BYTE, 32]], 1907 ["DF", 'DOUBLE_-FLOAT]] 1908 1909get_type_tag(lt) == 1910 res := false 1911 for tp in $type_tags while not(res) repeat 1912 ct := tp.1 1913 if SUBTYPEP(lt, ct) and SUBTYPEP(ct, lt) then 1914 res := tp.0 1915 res 1916 1917get_lisp_type(tt) == 1918 res := false 1919 for tp in $type_tags while not(res) repeat 1920 if tt = tp.0 then 1921 res := tp.1 1922 res 1923 1924-- Create a full isomorphic object which can be saved in a lisplib. 1925-- Note that dewritify(writify(x)) preserves UEQUALity of hashtables. 1926-- HASHTABLEs go both ways. 1927-- READTABLEs cannot presently be transformed back. 1928 1929writifyComplain s == 1930 $writifyComplained = true => nil 1931 $writifyComplained := true 1932 sayKeyedMsg("S2IH0027",[s]) 1933 1934spadClosure? ob == 1935 fun := QCAR ob 1936 not (FUNCTIONP fun) => nil 1937 not (name := BPINAME fun) => nil 1938 name = "WRAPPED" => nil 1939 vec := QCDR ob 1940 not VECP vec => nil 1941 name 1942 1943dewritify ob == 1944 (not ScanOrPairVec(function is?, ob) 1945 where is? a == a = 'WRITIFIED_!_!) => ob 1946 1947 $seen : local := MAKE_HASHTABLE('EQ) 1948 1949 dewritifyInner ob where 1950 dewritifyInner ob == 1951 null ob => nil 1952 e := HGET($seen, ob) => e 1953 1954 PAIRP ob and first ob = 'WRITIFIED_!_! => 1955 type := ob.1 1956 type = 'SELF => 1957 'WRITIFIED_!_! 1958 type = 'BPI => 1959 oname := ob.2 1960 f := 1961 -- FIXME: GENSYMMER is nowhere defined 1962 INTEGERP oname => EVAL GENSYMMER oname 1963 SYMBOL_-FUNCTION oname 1964 not COMPILED_-FUNCTION_-P f => 1965 error '"A required BPI does not exist." 1966 #ob > 3 and HASHEQ f ~= ob.3 => 1967 error '"A required BPI has been redefined." 1968 HPUT($seen, ob, f) 1969 f 1970 type = 'TYARR => 1971 lt := get_lisp_type(ob.2) 1972 nob := MAKE_TYPED_ARRAY(ob.3, lt) 1973 HPUT($seen, ob, nob) 1974 HPUT($seen, nob, nob) 1975 ov := ob.4 1976 n := ARRAY_-TOTAL_-SIZE(nob) 1977 for i in 0..(n - 1) repeat 1978 SETF(ROW_-MAJOR_-AREF(nob, i), 1979 dewritifyInner(QVELT(ov, i))) 1980 nob 1981 type = 'HASHTABLE => 1982 nob := MAKE_HASHTABLE(ob.2) 1983 HPUT($seen, ob, nob) 1984 HPUT($seen, nob, nob) 1985 for k in ob.3 for e in ob.4 repeat 1986 HPUT(nob, dewritifyInner k, dewritifyInner e) 1987 nob 1988 type = 'DEVALUATED => 1989 nob := EVAL dewritifyInner ob.2 1990 HPUT($seen, ob, nob) 1991 HPUT($seen, nob, nob) 1992 nob 1993 type = 'SPADCLOSURE => 1994 vec := dewritifyInner ob.2 1995 name := ob.3 1996 not FBOUNDP name => 1997 error STRCONC('"undefined function: ", SYMBOL_-NAME name) 1998 nob := CONS(SYMBOL_-FUNCTION name, vec) 1999 HPUT($seen, ob, nob) 2000 HPUT($seen, nob, nob) 2001 nob 2002 type = 'PLACE => 2003 nob := get_read_placeholder() 2004 HPUT($seen, ob, nob) 2005 HPUT($seen, nob, nob) 2006 nob 2007 type = 'READTABLE => 2008 error '"Cannot de-writify a read table." 2009 type = 'NULLSTREAM => $NullStream 2010 type = 'NONNULLSTREAM => $NonNullStream 2011 type = 'FLOAT => 2012 [fval, signif, expon, sign] := CDDR ob 2013 fval := SCALE_-FLOAT( FLOAT(signif, fval), expon) 2014 sign<0 => -fval 2015 fval 2016 error '"Unknown type to de-writify." 2017 2018 PAIRP ob => 2019 qcar := QCAR ob 2020 qcdr := QCDR ob 2021 nob := CONS(qcar, qcdr) 2022 HPUT($seen, ob, nob) 2023 HPUT($seen, nob, nob) 2024 QRPLACA(nob, dewritifyInner qcar) 2025 QRPLACD(nob, dewritifyInner qcdr) 2026 nob 2027 VECP ob => 2028 n := QVMAXINDEX ob 2029 nob := MAKE_VEC(n + 1) 2030 HPUT($seen, ob, nob) 2031 HPUT($seen, nob, nob) 2032 for i in 0..n repeat 2033 QSETVELT(nob, i, dewritifyInner QVELT(ob,i)) 2034 nob 2035 GENERAL_ARRAY?(ob) => 2036 dims := ARRAY_-DIMENSIONS(ob) 2037 nob := MAKE_-ARRAY(dims) 2038 HPUT($seen, ob, nob) 2039 HPUT($seen, nob, nob) 2040 n := ARRAY_-TOTAL_-SIZE(ob) 2041 for i in 0..(n - 1) repeat 2042 SETF(ROW_-MAJOR_-AREF(nob, i), 2043 dewritifyInner(ROW_-MAJOR_-AREF(ob, i))) 2044 nob 2045 SPAD_KERNEL_-P(ob) => 2046 nob := makeSpadKernel(NIL, NIL, SPAD_KERNEL_-NEST(ob)) 2047 HPUT($seen, ob, nob) 2048 HPUT($seen, nob, nob) 2049 SETF(SPAD_KERNEL_-OP(nob), _ 2050 dewritifyInner SPAD_KERNEL_-OP(ob)) 2051 SETF(SPAD_KERNEL_-ARG(nob), _ 2052 dewritifyInner SPAD_KERNEL_-ARG(ob)) 2053 nob 2054 -- Default case: return the object itself. 2055 ob 2056 2057ScanOrPairVec(f, ob) == 2058 $seen : local := MAKE_HASHTABLE('EQ) 2059 2060 CATCH('ScanOrPairVecAnswer, ScanOrInner(f, ob)) where 2061 ScanOrInner(f, ob) == 2062 HGET($seen, ob) => nil 2063 PAIRP ob => 2064 HPUT($seen, ob, true) 2065 ScanOrInner(f, QCAR ob) 2066 ScanOrInner(f, QCDR ob) 2067 nil 2068 VECP ob => 2069 HPUT($seen, ob, true) 2070 for i in 0..#ob-1 repeat ScanOrInner(f, ob.i) 2071 nil 2072 GENERAL_ARRAY?(ob) => 2073 HPUT($seen, ob, true) 2074 n := ARRAY_-TOTAL_-SIZE(ob) 2075 for i in 0..(n - 1) repeat 2076 ScanOrInner(f, ROW_-MAJOR_-AREF(ob, i)) 2077 nil 2078 SPAD_KERNEL_-P(ob) => 2079 ScanOrInner(f, SPAD_KERNEL_-OP(ob)) 2080 ScanOrInner(f, SPAD_KERNEL_-ARG(ob)) 2081 FUNCALL(f, ob) => 2082 THROW('ScanOrPairVecAnswer, true) 2083 nil 2084 2085--% )library 2086 2087library(args) == 2088 $newConlist : local := [] 2089 original_directory := GET_-CURRENT_-DIRECTORY() 2090 LOCALDATABASE(args, $options) 2091 extendLocalLibdb($newConlist) 2092 CHDIR(original_directory) 2093 terminateSystemCommand() 2094 2095 2096--% )load 2097 2098load args == loadSpad2Cmd args 2099 2100loadSpad2Cmd args == 2101 sayKeyedMsg("S2IU0003", nil) 2102 NIL 2103 2104reportCount () == 2105 centerAndHighlight(" Current Count Settings ",$LINELENGTH,specialChar 'hbar) 2106 SAY " " 2107 sayBrightly [:bright " cache",fillerSpaces(30,'".")," ",$cacheCount] 2108 if $cacheAlist then 2109 for [a,:b] in $cacheAlist repeat 2110 aPart:= linearFormatName a 2111 n:= sayBrightlyLength aPart 2112 sayBrightly concat(" ",aPart," ",fillerSpaces(32-n,'".")," ",b) 2113 SAY " " 2114 sayBrightly [:bright " stream",fillerSpaces(29,'".")," ",$streamCount] 2115 2116--% )nopiles 2117 2118nopiles l == nopilesSpad2Cmd l 2119 2120nopilesSpad2Cmd l == 2121 null l => setNopiles ("{") 2122 #l > 1 => 2123 SAY "nopiles takes a single argument" 2124 #l = 0 => setNopiles ("{") 2125 l is [opt] => 2126 opt = 'brace => setNopiles ("{") 2127 opt = 'parenthesis => setNopiles ("(") 2128 SAY "nopiles only takes 'brace' or 'parenthesis' as an argument" 2129 2130 2131--% )quit 2132 2133pquit() == pquitSpad2Cmd() 2134 2135pquitSpad2Cmd() == 2136 $quitCommandType :local := 'protected 2137 quitSpad2Cmd() 2138 2139quit() == quitSpad2Cmd() 2140 2141quitSpad2Cmd() == 2142 $quitCommandType ~= 'protected => leaveScratchpad() 2143 x := UPCASE queryUserKeyedMsg("S2IZ0031",NIL) 2144 MEMQ(STRING2ID_N(x, 1), '(Y YES)) => leaveScratchpad() 2145 sayKeyedMsg("S2IZ0032",NIL) 2146 terminateSystemCommand() 2147 2148leaveScratchpad () == QUIT() 2149 2150--% )read 2151 2152DEFVAR($nopiles, false) 2153 2154read l == readSpad2Cmd l 2155 2156readSpad2Cmd l == 2157 $InteractiveMode : local := true 2158 quiet := nil 2159 ifthere := nil 2160 for [opt,:.] in $options repeat 2161 fullopt := selectOptionLC(opt,'(quiet test ifthere),'optionError) 2162 fullopt = 'ifthere => ifthere := true 2163 fullopt = 'quiet => quiet := true 2164 2165 if null(l) and (ef := $edit_file) and pathnameTypeId(ef) ~= 'SPAD then 2166 l := pathname(ef) 2167 else 2168 l := pathname l 2169 devFTs := '("input" "INPUT" "boot" "BOOT" "lisp" "LISP") 2170 fileTypes := 2171 $UserLevel = 'interpreter => '("input" "INPUT") 2172 $UserLevel = 'compiler => '("input" "INPUT") 2173 devFTs 2174 ll := find_file(l, fileTypes) 2175 if null ll then 2176 ifthere => return nil -- be quiet about it 2177 throwKeyedMsg("S2IL0003",[namestring l]) 2178 ll := pathname ll 2179 ft := pathnameType ll 2180 upft := UPCASE ft 2181 null member(upft,fileTypes) => 2182 fs := namestring l 2183 member(upft,devFTs) => throwKeyedMsg("S2IZ0033",[fs]) 2184 throwKeyedMsg("S2IZ0034",[fs]) 2185 do_read(ll, quiet, $nopiles) 2186 2187do_read(ll, quiet, pile_mode) == 2188 $nopiles : local := pile_mode 2189 $edit_file := ll 2190 read_or_compile(quiet, false) 2191 terminateSystemCommand() 2192 spadPrompt() 2193 2194basename(x) == NAMESTRING(PATHNAME_-NAME(x)) 2195 2196read_or_compile(quiet, lib) == 2197 $LISPLIB : local := lib 2198 input_file := make_input_filename($edit_file) 2199 type := PATHNAME_-TYPE(input_file) 2200 type = '"boot" => 2201 lfile := CONCAT(basename(input_file), '".clisp") 2202 BOOTTOCLC(input_file, lfile) 2203 LOAD(COMPILE_-FILE(lfile)) 2204 type = '"lisp" => 2205 ffile := CONCAT(basename(input_file), ".", $lisp_bin_filetype) 2206 LOAD(FRICAS_COMPILE_FASL(input_file, ffile)) 2207 type = '"bbin" => LOAD(input_file) 2208 type = '"input" => ncINTERPFILE(input_file, not(quiet)) 2209 spadCompile(input_file) 2210 2211--% )show 2212 2213show l == 2214 ioHook("startSysCmd", "show") 2215 showSpad2Cmd l 2216 ioHook("endSysCmd", "show") 2217 2218showSpad2Cmd l == 2219 l = [NIL] => helpSpad2Cmd '(show) 2220 $showOptions : local := '(operations) 2221 if null $options then $options := '((operations)) 2222 $e : local := $InteractiveFrame 2223 $env : local := $InteractiveFrame 2224 l is [constr] => 2225 constr in '(Union Record Mapping) => 2226 constr = 'Record => 2227 sayKeyedMsg("S2IZ0044R",[constr, '")show Record(a: Integer, b: String)"]) 2228 constr = 'Mapping => 2229 sayKeyedMsg("S2IZ0044M",NIL) 2230 sayKeyedMsg("S2IZ0045T",[constr, '")show Union(a: Integer, b: String)"]) 2231 sayKeyedMsg("S2IZ0045U",[constr, '")show Union(Integer, String)"]) 2232 constr is ['Mapping, :.] => 2233 sayKeyedMsg("S2IZ0044M",NIL) 2234 reportOperations(constr,constr) 2235 reportOperations(l,l) 2236 2237reportOperations(oldArg,u) == 2238 -- u might be an uppercased version of oldArg 2239 $env:local := [[NIL]] 2240 $eval:local := true --generate code-- don't just type analyze 2241 $genValue:local := true --evaluate all generated code 2242 $resolve_level : local := 15 2243 null u => nil 2244 u = $quadSymbol => 2245 sayBrightly ['" mode denotes", :bright '"any", "type"] 2246 u = "%" => 2247 sayKeyedMsg("S2IZ0063",NIL) 2248 sayKeyedMsg("S2IZ0064",NIL) 2249 u isnt ['Record,:.] and u isnt ['Union,:.] and 2250 null(isNameOfType u) and u isnt ['typeOf,.] => 2251 if ATOM oldArg then oldArg := [oldArg] 2252 sayKeyedMsg("S2IZ0063",NIL) 2253 for op in oldArg repeat 2254 sayKeyedMsg("S2IZ0062",[opOf op]) 2255 (v := isDomainValuedVariable u) => reportOpsFromUnitDirectly0 v 2256 unitForm:= 2257 atom u => opOf unabbrev u 2258 unabbrev u 2259 atom unitForm => reportOpsFromLisplib0(unitForm,u) 2260 unitForm' := evaluateType unitForm 2261 tree := mkAtree removeZeroOneDestructively unitForm 2262 (unitForm' := isType tree) => reportOpsFromUnitDirectly0 unitForm' 2263 sayKeyedMsg("S2IZ0041",[unitForm]) 2264 2265reportOpsFromUnitDirectly0 D == 2266 $useEditorForShowOutput => 2267 reportOpsFromUnitDirectly1 D 2268 reportOpsFromUnitDirectly D 2269 2270reportOpsFromUnitDirectly1 D == 2271 showFile := pathname ['SHOW,'LISTING] 2272 erase_lib([showFile]) 2273 $sayBrightlyStream : fluid := MAKE_OUTSTREAM(showFile) 2274 sayShowWarning() 2275 reportOpsFromUnitDirectly D 2276 SHUT $sayBrightlyStream 2277 editFile showFile 2278 2279sayShowWarning() == 2280 sayBrightly 2281 '"Warning: this is a temporary file and will be deleted the next" 2282 sayBrightly 2283 '" time you use )show. Rename it and FILE if you wish to" 2284 sayBrightly 2285 '" save the contents." 2286 sayBrightly '"" 2287 2288reportOpsFromLisplib0(unitForm,u) == 2289 $useEditorForShowOutput => reportOpsFromLisplib1(unitForm,u) 2290 reportOpsFromLisplib(unitForm,u) 2291 2292reportOpsFromLisplib1(unitForm,u) == 2293 showFile := pathname ['SHOW,'LISTING] 2294 erase_lib([showFile]) 2295 $sayBrightlyStream : fluid := MAKE_OUTSTREAM(showFile) 2296 sayShowWarning() 2297 reportOpsFromLisplib(unitForm,u) 2298 SHUT $sayBrightlyStream 2299 editFile showFile 2300 2301reportOpsFromUnitDirectly unitForm == 2302 isRecordOrUnion := unitForm is [a,:.] and a in '(Record Union) 2303 unit:= evalDomain unitForm 2304 [top, :argl] := unitForm 2305 kind:= GETDATABASE(top,'CONSTRUCTORKIND) 2306 2307 sayBrightly concat('%b,formatOpType unitForm, 2308 '%d,'"is a",'%b,kind,'%d, '"constructor.") 2309 if not isRecordOrUnion then 2310 abb := GETDATABASE(top,'ABBREVIATION) 2311 sourceFile := GETDATABASE(top,'SOURCEFILE) 2312 sayBrightly ['" Abbreviation for",:bright top,'"is",:bright abb] 2313 verb := 2314 isExposedConstructor top => '"is" 2315 '"is not" 2316 sayBrightly ['" This constructor",:bright verb, 2317 '"exposed in this frame."] 2318 -- -- Disabled because the path is wrong. 2319 -- sayBrightly ['" Issue",:bright STRCONC('")edit ", 2320 -- namestring sourceFile),'"to see algebra source code for", 2321 -- :bright abb,'%l] 2322 2323 for [opt] in $options repeat 2324 opt := selectOptionLC(opt,$showOptions,'optionError) 2325 opt = 'operations => 2326 if isRecordOrUnion 2327 then 2328 constructorFunction := get_oplist_maker(top) or 2329 systemErrorHere '"reportOpsFromUnitDirectly" 2330 [funlist,.]:= FUNCALL(constructorFunction,"$",unitForm, 2331 $CategoryFrame) 2332 sigList := REMDUP MSORT [[[a,b],true,[c,0,1]] for 2333 [a,b,c] in funlist] 2334 else 2335 sigList:= REMDUP MSORT getOplistForConstructorForm unitForm 2336 2337 $commentedOps: local := 0 2338 ops := nil 2339 2340 if kind = 'category then 2341 sigList := EQSUBSTLIST(argl,$FormalMapVariableList, sigList) 2342 ops := [formatOperationWithPred(x) for x in sigList] 2343 else 2344 $predicateList: local := GETDATABASE(top, 'PREDICATES) 2345 -- x.1 is the type predicate of operation x 2346 sigList := [x for x in sigList | evalDomainOpPred(unit, x.1)] 2347 -- first(first(x)) is the name of operation x 2348 numOfNames := # REMDUP [first(first(x)) for x in sigList] 2349 sayBrightly ['" ", numOfNames, '" Names for ", #sigList, 2350 '" Operations in this Domain."] 2351 2352 --new form is (<op> <signature> <slotNumber> <condition> <kind>) 2353 ops := [formatOperation(x, unit) for x in sigList] 2354 2355 centerAndHighlight('"Operations", $LINELENGTH, specialChar 'hbar) 2356 sayBrightly '"" 2357 say2PerLine ops 2358 2359 if $commentedOps ~= 0 then 2360 sayBrightly 2361 ['"Functions that are not yet implemented are preceded by", 2362 :bright '"--"] 2363 sayBrightly '"" 2364 NIL 2365 2366reportOpsFromLisplib(op,u) == 2367 null(fn:= constructor? op) => sayKeyedMsg("S2IZ0054",[u]) 2368 argml := 2369 (s := getConstructorSignature op) => IFCDR s 2370 NIL 2371 typ:= GETDATABASE(op,'CONSTRUCTORKIND) 2372 nArgs:= #argml 2373 nArgs = 0 and typ = 'domain => 2374 reportOpsFromUnitDirectly0 isType mkAtree evaluateType [op] 2375 argList := IFCDR GETDATABASE(op, 'CONSTRUCTORFORM) 2376 functorForm:= [op,:argList] 2377 argml:= EQSUBSTLIST(argList,$FormalMapVariableList,argml) 2378 functorFormWithDecl:= [op,:[[":",a,m] for a in argList for m in argml]] 2379 sayBrightly concat(bright form2StringWithWhere functorFormWithDecl, 2380 '"is a",bright typ,'"constructor") 2381 sayBrightly ['" Abbreviation for",:bright op,'"is",:bright fn] 2382 verb := 2383 isExposedConstructor op => '"is" 2384 '"is not" 2385 sayBrightly ['" This constructor",:bright verb, 2386 '"exposed in this frame."] 2387 sourceFile := GETDATABASE(op,'SOURCEFILE) 2388 -- -- Disabled because the path is wrong. 2389 -- sayBrightly ['" Issue",:bright STRCONC('")edit ", 2390 -- namestring sourceFile), 2391 -- '"to see algebra source code for",:bright fn,'%l] 2392 2393 for [opt] in $options repeat 2394 opt := selectOptionLC(opt,$showOptions,'optionError) 2395 opt = 'layout => 2396 dc1 fn 2397 opt = 'views => sayBrightly ['"To get",:bright '"views", 2398 '"you must give parameters of constructor"] 2399 opt = 'operations => displayOperationsFromLisplib functorForm 2400 nil 2401 2402displayOperationsFromLisplib form == 2403 [name,:argl] := form 2404 kind := GETDATABASE(name,'CONSTRUCTORKIND) 2405 centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) 2406 sayBrightly '"" 2407 opList:= GETDATABASE(name,'OPERATIONALIST) 2408 null opList => nil 2409 opl:=REMDUP MSORT EQSUBSTLIST(argl,$FormalMapVariableList,opList) 2410 ops:= nil 2411 for x in opl repeat 2412 ops := [:ops,:formatOperationAlistEntry(x)] 2413 say2PerLine ops 2414 nil 2415 2416--% )spool 2417 2418spool(filename) == 2419 null(filename) => 2420 DRIBBLE() 2421 TERPRI() 2422 reset_highlight() 2423 filename := first(filename) 2424 if SYMBOLP(filename) then filename := SYMBOL_-NAME(filename) 2425 PROBE_-FILE(filename) => 2426 ERROR(FORMAT(nil, '"file ~a already exists", filename)) 2427 DRIBBLE(filename) 2428 TERPRI() 2429 clear_highlight() 2430 2431--% )synonym 2432 2433synonym(:l) == synonymSpad2Cmd() -- always passed a null list 2434 2435synonymSpad2Cmd() == 2436 line := getSystemCommandLine() 2437 if line = '"" then printSynonyms(NIL) 2438 else 2439 pair := processSynonymLine line 2440 if $CommandSynonymAlist then 2441 PUTALIST($CommandSynonymAlist, first pair, rest pair) 2442 else $CommandSynonymAlist := [pair] 2443 terminateSystemCommand() 2444 2445processSynonymLine line == 2446 key := STRING2ID_N (line, 1) 2447 value := removeKeyFromLine line where 2448 removeKeyFromLine line == 2449 line := dropLeadingBlanks line 2450 mx := MAXINDEX line 2451 for i in 0..mx repeat 2452 line.i = " " => 2453 return (for j in (i+1)..mx repeat 2454 line.j ~= " " => return (SUBSTRING (line, j, nil))) 2455 [key, :value] 2456 2457 2458--% 2459--% )undo 2460--% 2461 2462$undoFlag := true --Default setting for undo is "on" 2463 2464 2465undo(l) == 2466--undo takes one option ")redo" which simply reads "redo.input", 2467-- a file created by every normal )undo command (see below) 2468 undoWhen := 'after 2469 if $options is [[key]] then 2470 stringPrefix?(s := PNAME key,'"redo") => 2471 $options := nil --clear $options so that "read" won't see them 2472 read '(redo_.input) 2473 not stringPrefix?(s,'"before") => 2474 userError '"only option to undo is _")redo_"" 2475 undoWhen := 'before 2476 n := 2477 null l => -1 2478 first l 2479 if IDENTP n then 2480 n := PARSE_-INTEGER PNAME n 2481 if not FIXP n then userError '"undo argument must be an integer" 2482 $InteractiveFrame := undoSteps(undoCount n,undoWhen) 2483 nil 2484 2485recordFrame(systemNormal) == 2486 null $undoFlag => nil --do nothing if facility is turned off 2487 currentAlist := IFCAR $frameRecord 2488 delta := diffAlist(CAAR $InteractiveFrame,$previousBindings) 2489 if systemNormal = 'system then 2490 null delta => return nil --do not record 2491 delta := ['systemCommand,:delta] 2492 $frameRecord := [delta,:$frameRecord] 2493 $previousBindings := --copy all but the individual properties 2494 [CONS(first x, [CONS(first y, rest y) for y in rest x]) for x 2495 in CAAR $InteractiveFrame] 2496 first $frameRecord 2497 2498diffAlist(new,old) == 2499--record only those properties which are different 2500 for (pair := [name,:proplist]) in new repeat 2501 -- name has an entry both in new and old world 2502 -- (1) if the old world had no proplist for that variable, then 2503 -- record NIL as the value of each new property 2504 -- (2) if the old world does have a proplist for that variable, then 2505 -- a) for each property with a value: give the old value 2506 -- b) for each property missing: give NIL as the old value 2507 oldPair := ASSQ(name,old) => 2508 null (oldProplist := rest oldPair) => 2509 --record old values of new properties as NIL 2510 acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc] 2511 deltas := nil 2512 for (propval := [prop,:val]) in proplist repeat 2513 null (oldPropval := assoc(prop,oldProplist)) => --missing property 2514 deltas := [[prop],:deltas] 2515 EQ(rest oldPropval, val) => 'skip 2516 deltas := [oldPropval,:deltas] 2517 deltas => acc := [[name,:NREVERSE deltas],:acc] 2518 acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc] 2519--record properties absent on new list (say, from a )cl all) 2520 for (oldPair := [name,:r]) in old repeat 2521 r and null QLASSQ(name, new) => 2522 acc := [oldPair,:acc] 2523 -- name has an entry both in new and old world 2524 -- (1) if the new world has no proplist for that variable 2525 -- (a) if the old world does, record the old proplist 2526 -- (b) if the old world does not, record nothing 2527 -- (2) if the new world has a proplist for that variable, it has 2528 -- been handled by the first loop. 2529 res := NREVERSE acc 2530 if BOUNDP '$reportUndo and $reportUndo then reportUndo res 2531 res 2532 2533reportUndo acc == 2534 for [name,:proplist] in acc repeat 2535 sayBrightly STRCONC("Properties of ",PNAME name,'" ::") 2536 curproplist := LASSOC(name,CAAR $InteractiveFrame) 2537 for [prop,:value] in proplist repeat 2538 sayBrightlyNT ['" ",prop,'" was: "] 2539 pp value 2540 sayBrightlyNT ['" ",prop,'" is: "] 2541 pp LASSOC(prop,curproplist) 2542 2543clearFrame() == 2544 clearCmdAll() 2545 $frameRecord := nil 2546 $previousBindings := nil 2547 2548 2549--======================================================================= 2550-- Undoing previous m commands 2551--======================================================================= 2552undoCount(n) == --computes the number of undo's, given $IOindex 2553 m := 2554 n >= 0 => $IOindex - n - 1 2555 -n 2556 m >= $IOindex => userError STRCONC('"Magnitude of undo argument must be less than step number (",STRINGIMAGE $IOindex,'").") 2557 m 2558 2559 2560undoSteps(m,beforeOrAfter) == 2561-- undoes m previous commands; if )before option, then undo one extra at end 2562--Example: if $IOindex now is 6 and m = 2 then general layout of $frameRecord, 2563-- after the call to recordFrame below will be: 2564-- (<change for systemcommands> 2565-- (<change for #5> <change for system commands> 2566-- (<change for #4> <change for system commands> 2567-- (<change for #3> <change for system commands> 2568-- <change for #2> <change for system commands> 2569-- <change for #1> <change for system commands>) where system 2570-- command entries are optional and identified by (systemCommand . change). 2571-- For a ")undo 3 )after", m = 2 and undoStep swill restore the environment 2572-- up to, but not including <change for #3>. 2573-- An "undo 3 )before" will additionally restore <change for #3>. 2574-- Thus, the later requires one extra undo at the end. 2575 writeInputLines('redo,$IOindex - m) 2576 recordFrame('normal) --do NOT mark this as a system command change 2577 --do this undo FIRST (i=0 case) 2578 env := COPY CAAR $InteractiveFrame 2579 for i in 0..m for framelist in tails $frameRecord repeat 2580 env := undoSingleStep(first framelist,env) 2581 framelist is [.,['systemCommand,:systemDelta],:.] => 2582 framelist := rest framelist --undoing system commands given 2583 env := undoSingleStep(systemDelta,env) -- before command line 2584 lastTailSeen := framelist 2585 if beforeOrAfter = 'before then --do one additional undo for )before 2586 env := undoSingleStep(first rest lastTailSeen,env) 2587 $frameRecord := rest $frameRecord --flush the effect of extra recordFrame 2588 $InteractiveFrame := LIST LIST env 2589 2590 2591undoSingleStep(changes,env) == 2592--Each change is a name-proplist pair. For each change: 2593-- (1) if there exists a proplist in env, then for each prop-value change: 2594-- (a) if the prop exists in env, RPLAC in the change value 2595-- (b) otherwise, CONS it onto the front of prop-values for that name 2596-- (2) add change to the front of env 2597-- pp '"----Undoing 1 step--------" 2598-- pp changes 2599 for (change := [name,:changeList]) in changes repeat 2600 if LASSOC('localModemap,changeList) then 2601 changeList := undoLocalModemapHack changeList 2602 pairlist := ASSQ(name,env) => 2603 proplist := rest pairlist => 2604 for (pair := [prop,:value]) in changeList repeat 2605 node := ASSQ(prop,proplist) => RPLACD(node,value) 2606 RPLACD(proplist, [first proplist, :rest proplist]) 2607 RPLACA(proplist,pair) 2608 RPLACD(pairlist,changeList) 2609 env := [change,:env] 2610 env 2611 2612undoLocalModemapHack changeList == 2613 [newPair for (pair := [name,:value]) in changeList | newPair] where newPair == 2614 name = 'localModemap => [name] 2615 pair 2616 2617removeUndoLines u == --called by writeInputLines 2618 xtra := 2619 STRINGP $currentLine => [$currentLine] 2620 REVERSE $currentLine 2621 xtra := [x for x in xtra | not stringPrefix?('")history",x)] 2622 u := [:u, :xtra] 2623 not (or/[stringPrefix?('")undo",x) for x in u]) => u 2624 --(1) reverse the list 2625 --(2) walk down the (reversed) list: when >n appears remove: 2626 -- (a) system commands 2627 -- (b) if n > 0: (replace n by n-1; remove a command; repeat (a-b)) 2628 savedIOindex := $IOindex --save value 2629 $IOindex := 1 2630 for y in tails u repeat 2631 (x := first y).0 = char '_) => 2632 stringPrefix?('")undo",s := trimString x) => --parse "undo )option" 2633 s1 := trimString SUBSTRING(s,5,nil) 2634 if s1 ~= '")redo" then 2635 m := charPosition(char '_),s1,0) 2636 code := 2637 m < MAXINDEX s1 => s1.(m + 1) 2638 char 'a 2639 s2 := trimString SUBSTRING(s1,0,m) 2640 n := 2641 s1 = '")redo" => 0 2642 s2 ~= '"" => undoCount PARSE_-INTEGER s2 2643 -1 2644 RPLACA(y,CONCAT('">",code,STRINGIMAGE n)) 2645 nil 2646 $IOindex := $IOindex + 1 --referenced by undoCount 2647 acc := nil 2648 for y in tails NREVERSE u repeat 2649 (x := first y).0 = char '_> => 2650 code := x . 1 --code = a,b, or r 2651 n := PARSE_-INTEGER SUBSTRING(x,2,nil) --n = number of undo steps 2652 y := rest y --kill >n line 2653 while y repeat 2654 c := first y 2655 c.0 = char '_) or c.0 = char '_> => y := rest y --kill system commands 2656 n = 0 => return nil --including undos 2657 n := n - 1 2658 y := rest y --kill command 2659 y and code~= char 'b => acc := [c,:acc] --add last unless )before 2660 acc := [x,:acc] 2661 $IOindex := savedIOindex 2662 acc 2663 2664 2665 2666 2667--% )what 2668 2669 2670what l == 2671 ioHook("startSysCmd", "what") 2672 whatSpad2Cmd l 2673 ioHook("endSysCmd", "what") 2674 2675whatSpad2Cmd l == 2676 $e:local := $EmptyEnvironment 2677 null l => reportWhatOptions() 2678 [key0,:args] := l 2679 key := selectOptionLC(key0,$whatOptions,nil) 2680 null key => sayKeyedMsg("S2IZ0043",NIL) 2681 args := [fixpat p for p in args] where 2682 fixpat x == 2683 x is [x',:.] => DOWNCASE x' 2684 DOWNCASE x 2685 key = 'things => 2686 for opt in $whatOptions repeat 2687 not MEMQ(opt,'(things)) => whatSpad2Cmd [opt,:args] 2688 key = 'categories => 2689 filterAndFormatConstructors('category,'"Categories",args) 2690 key = 'commands => 2691 whatCommands(args) 2692 key = 'domains => 2693 filterAndFormatConstructors('domain,'"Domains",args) 2694 key = 'operations => 2695 apropos args 2696 key = 'packages => 2697 filterAndFormatConstructors('package,'"Packages",args) 2698 key = 'synonyms => 2699 printSynonyms(args) 2700 2701filterAndFormatConstructors(constrType,label,patterns) == 2702 centerAndHighlight(label,$LINELENGTH,specialChar 'hbar) 2703 l := filterListOfStringsWithFn(patterns,whatConstructors constrType, 2704 function rest) 2705 if patterns then 2706 null l => 2707 sayMessage ['" No ",label,'" with names matching patterns:", 2708 '%l,'" ",'%b,:blankList patterns,'%d] 2709 sayMessage [label,'" with names matching patterns:", 2710 '%l,'" ",'%b,:blankList patterns,'%d] 2711 l => pp2Cols l 2712 2713whatConstructors constrType == 2714 -- here constrType should be one of 'category, 'domain, 'package 2715 MSORT [CONS(GETDATABASE(con,'ABBREVIATION), STRING(con)) 2716 for con in allConstructors() 2717 | GETDATABASE(con,'CONSTRUCTORKIND) = constrType] 2718 2719apropos l == 2720 -- l is a list of operation name fragments 2721 -- this displays all operation names containing these fragments 2722 ops := 2723 null l => allOperations() 2724 filterListOfStrings([(DOWNCASE STRINGIMAGE p) for p in l],allOperations()) 2725 ops => 2726 sayMessage '"Operations whose names satisfy the above pattern(s):" 2727 sayAsManyPerLineAsPossible MSORT ops 2728 sayKeyedMsg("S2IF0011",[first ops]) 2729 sayMessage '" There are no operations containing those patterns" 2730 NIL 2731 2732 2733printSynonyms(patterns) == 2734 centerAndHighlight("System Command Synonyms",$LINELENGTH,specialChar 'hbar) 2735 ls := filterListOfStringsWithFn(patterns, [[STRINGIMAGE a,:b] 2736 for [a,:b] in synonymsForUserLevel $CommandSynonymAlist], 2737 function first) 2738 printLabelledList(ls,'"user",'"synonyms",'")",patterns) 2739 nil 2740 2741printLabelledList(ls,label1,label2,prefix,patterns) == 2742 -- prefix goes before each element on each side of the list, eg, 2743 -- ")" 2744 null ls => 2745 null patterns => 2746 sayMessage ['" No ",label1,'"-defined ",label2,'" in effect."] 2747 sayMessage ['" No ",label1,'"-defined ",label2,'" satisfying patterns:", 2748 '%l,'" ",'%b,:blankList patterns,'%d] 2749 if patterns then 2750 sayMessage [label1,'"-defined ",label2,'" satisfying patterns:", 2751 '%l,'" ",'%b,:blankList patterns,'%d] 2752 for [syn,:comm] in ls repeat 2753 if SUBSTRING(syn,0,1) = '"|" then syn := SUBSTRING(syn,1,NIL) 2754 if syn = '"%i" then syn := '"%i " 2755 wid := MAX(30 - (entryWidth syn),1) 2756 sayBrightly concat('%b,prefix,syn,'%d, 2757 fillerSpaces(wid,'"."),'" ",prefix,comm) 2758 sayBrightly '"" 2759 2760whatCommands(patterns) == 2761 label := STRCONC("System Commands for User Level: ", 2762 STRINGIMAGE $UserLevel) 2763 centerAndHighlight(label,$LINELENGTH,specialChar 'hbar) 2764 l := filterListOfStrings(patterns, 2765 [(STRINGIMAGE a) for a in commandsForUserLevel $systemCommands]) 2766 if patterns then 2767 null l => 2768 sayMessage ['"No system commands at this level matching patterns:", 2769 '%l,'" ",'%b,:blankList patterns,'%d] 2770 sayMessage ['"System commands at this level matching patterns:", 2771 '%l,'" ",'%b,:blankList patterns,'%d] 2772 if l then 2773 sayAsManyPerLineAsPossible l 2774 SAY " " 2775 patterns => nil -- don't be so verbose 2776 sayKeyedMsg("S2IZ0046",NIL) 2777 nil 2778 2779reportWhatOptions() == 2780 optList1:= "append"/[['%l,'" ",x] for x in $whatOptions] 2781 sayBrightly 2782 ['%b,'" )what",'%d,'"argument keywords are",'%b,:optList1,'%d,'%l, 2783 '" or abbreviations thereof.",'%l, 2784 '%l,'" Issue",'%b,'")what ?",'%d,'"for more information."] 2785 2786filterListOfStrings(patterns,names) == 2787 -- names and patterns are lists of strings 2788 -- returns: list of strings in names that contains any of the strings 2789 -- in patterns 2790 (null patterns) or (null names) => names 2791 names' := NIL 2792 for name in reverse names repeat 2793 satisfiesRegularExpressions(name,patterns) => 2794 names' := [name,:names'] 2795 names' 2796 2797filterListOfStringsWithFn(patterns,names,fn) == 2798 -- names and patterns are lists of strings 2799 -- fn is something like first or CADR 2800 -- returns: list of strings in names that contains any of the strings 2801 -- in patterns 2802 (null patterns) or (null names) => names 2803 names' := NIL 2804 for name in reverse names repeat 2805 satisfiesRegularExpressions(FUNCALL(fn,name),patterns) => 2806 names' := [name,:names'] 2807 names' 2808 2809satisfiesRegularExpressions(name,patterns) == 2810 -- this is a first cut 2811 nf := true 2812 dname := DOWNCASE COPY name 2813 for pattern in patterns while nf repeat 2814 -- use @ as a wildcard 2815 STRPOS(pattern,dname,0,'"@") => nf := nil 2816 null nf 2817 2818--% Synonym File Reader 2819 2820--------------------> NEW DEFINITION (override in util.lisp) 2821processSynonyms() == 2822 p := STRPOS('")",LINE,0,NIL) 2823 fill := '"" 2824 if p 2825 then 2826 line := SUBSTRING(LINE,p,NIL) 2827 if p > 0 then fill := SUBSTRING(LINE,0,p) 2828 else 2829 p := 0 2830 line := LINE 2831 to := STRPOS ('" ", line, 1, nil) 2832 if to then to := to - 1 2833 synstr := SUBSTRING (line, 1, to) 2834 syn := STRING2ID_N (synstr, 1) 2835 null (fun := LASSOC (syn, $CommandSynonymAlist)) => NIL 2836 to := STRPOS('")",fun,1,NIL) 2837 if to and to ~= SIZE(fun)-1 then 2838 opt := STRCONC('" ",SUBSTRING(fun,to,NIL)) 2839 fun := SUBSTRING(fun,0,to-1) 2840 else opt := '" " 2841 if (SIZE synstr) > (SIZE fun) then 2842 for i in (SIZE fun)..(SIZE synstr) repeat 2843 fun := CONCAT (fun, '" ") 2844 cl := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) 2845 SETQ(LINE,cl) 2846 SETQ(CHR,LINE.(p+1)) 2847 processSynonyms () 2848 2849-- functions for interfacing to system commands from algebra code 2850-- common lisp dependent 2851 2852doSystemCommand string == 2853 string := CONCAT('")", string) 2854 LINE: fluid := string 2855 processSynonyms() 2856 string := LINE 2857 string:=SUBSTRING(string,1,nil) 2858 string = '"" => nil 2859 tok:=getFirstWord(string) 2860 tok => 2861 unab := unAbbreviateKeyword tok 2862 member(unab, $noParseCommands) => 2863 handleNoParseCommands(unab, string) 2864 optionList := splitIntoOptionBlocks string 2865 member(unab, $tokenCommands) => 2866 handleTokensizeSystemCommands(unab, optionList) 2867 handleParsedSystemCommands(unab, optionList) 2868 nil 2869 nil 2870 2871)if false 2872The system commands given by the global variable 2873[[|$noParseCommands|]]\cite{1} require essentially no 2874preprocessing/parsing of their arguments. Here we dispatch the 2875functions which implement these commands. 2876 2877There are four standard commands which receive arguments -- [[lisp]], 2878[[synonym]], [[system]] and [[boot]]. There are five standard commands 2879which do not receive arguments -- [[quit]], [[fin]], [[pquit]], 2880[[credits]] and [[copyright]]. As these commands do not necessarily 2881exhaust those mentioned in [[|$noParseCommands|]], we provide a 2882generic dispatch based on two conventions: commands which do not 2883require an argument name themselves, those which do have their names 2884prefixed by [[np]]. 2885)endif 2886handleNoParseCommands(unab, string) == 2887 string := stripSpaces string 2888 spaceIndex := SEARCH('" ", string) 2889 unab = "lisp" => 2890 if (null spaceIndex) then 2891 sayKeyedMsg("S2IV0005", NIL) 2892 nil 2893 else nplisp(stripLisp string) 2894 unab = "boot" => 2895 if (null spaceIndex) then 2896 sayKeyedMsg("S2IV0005", NIL) 2897 nil 2898 else npboot(SUBSEQ(string, spaceIndex+1)) 2899 unab = "system" => 2900 if (null spaceIndex) then 2901 sayKeyedMsg("S2IV0005", NIL) 2902 nil 2903 else npsystem(unab, string) 2904 unab = "synonym" => 2905 npsynonym(unab, (null spaceIndex => '""; SUBSEQ(string, spaceIndex+1))) 2906 null spaceIndex => 2907 FUNCALL unab 2908 member(unab, '( quit _ 2909 fin _ 2910 piles _ 2911 pquit _ 2912 credits _ 2913 copyright )) => 2914 sayKeyedMsg("S2IV0005", NIL) 2915 nil 2916 funName := INTERN CONCAT('"np",STRING unab) 2917 FUNCALL(funName, SUBSEQ(string, spaceIndex+1)) 2918 2919string2BootTree(str) == STTOSEX(str) 2920 2921npboot str == 2922 sex := string2BootTree str 2923 FORMAT(true, '"~&~S~%", sex) 2924 $ans := EVAL sex 2925 FORMAT(true, '"~&Value = ~S~%", $ans) 2926 2927stripLisp str == 2928 found := false 2929 strIndex := 0 2930 lispStr := '"lisp" 2931 for c0 in 0..#str-1 for c1 in 0..#lispStr-1 repeat 2932 (char str.c0) ~= (char lispStr.c1) => 2933 return nil 2934 strIndex := c0+1 2935 SUBSEQ(str, strIndex) 2936 2937 2938nplisp str == 2939 $ans := EVAL READ_-FROM_-STRING str 2940 FORMAT(true, '"~&Value = ~S~%", $ans) 2941 2942intnplisp s == 2943 $currentLine := s 2944 nplisp $currentLine 2945 2946npsystem(unab, str) == 2947 spaceIndex := SEARCH('" ", str) 2948 null spaceIndex => 2949 sayKeyedMsg("S2IZ0080", [str]) 2950 sysPart := SUBSEQ(str, 0, spaceIndex) 2951 -- The following is a hack required by the fact that unAbbreviateKeyword 2952 -- returns the word "system" for unknown words 2953 null SEARCH(sysPart, STRING unab) => 2954 sayKeyedMsg("S2IZ0080", [sysPart]) 2955 command := SUBSEQ(str, spaceIndex+1) 2956 OBEY command 2957 2958npsynonym(unab, str) == 2959 npProcessSynonym(str) 2960 2961tokenSystemCommand(unabr, tokList) == 2962 systemCommand tokList 2963 2964tokTran tok == 2965 STRINGP tok => 2966 #tok = 0 => nil 2967 isIntegerString tok => READ_-FROM_-STRING tok 2968 STRING tok.0 = '"_"" => 2969 SUBSEQ(tok, 1, #tok-1) 2970 INTERN tok 2971 tok 2972 2973isIntegerString tok == 2974 for i in 0..#tok-1 repeat 2975 val := DIGIT_-CHAR_-P tok.i 2976 not val => return nil 2977 val 2978 2979splitIntoOptionBlocks str == 2980 inString := false 2981 optionBlocks := nil 2982 blockStart := 0 2983 parenCount := 0 2984 for i in 0..#str-1 repeat 2985 STRING str.i = '"_"" => 2986 inString := not inString 2987 if STRING str.i = '"(" and not inString 2988 then parenCount := parenCount + 1 2989 if STRING str.i = '")" and not inString 2990 then parenCount := parenCount - 1 2991 STRING str.i = '")" and not inString and parenCount = -1 => 2992 block := stripSpaces SUBSEQ(str, blockStart, i) 2993 blockList := [block, :blockList] 2994 blockStart := i+1 2995 parenCount := 0 2996 blockList := [stripSpaces SUBSEQ(str, blockStart), :blockList] 2997 nreverse blockList 2998 2999dumbTokenize str == 3000 -- split into tokens delimited by spaces, taking quoted strings into account 3001 inString := false 3002 tokenList := nil 3003 tokenStart := 0 3004 previousSpace := false 3005 for i in 0..#str-1 repeat 3006 STRING str.i = '"_"" => 3007 inString := not inString 3008 previousSpace := false 3009 STRING str.i = '" " and not inString => 3010 previousSpace => nil 3011 token := stripSpaces SUBSEQ(str, tokenStart, i) 3012 tokenList := [token, :tokenList] 3013 tokenStart := i+1 3014 previousSpace := true 3015 previousSpace := false 3016 tokenList := [stripSpaces SUBSEQ(str, tokenStart), :tokenList] 3017 nreverse tokenList 3018 3019handleParsedSystemCommands(unabr, optionList) == 3020 restOptionList := [dumbTokenize opt for opt in rest optionList] 3021 parcmd := [parseSystemCmd first optionList, 3022 :[[tokTran tok for tok in opt] for opt in restOptionList]] 3023 systemCommand parcmd 3024 3025parseSystemCmd opt == 3026 spaceIndex := SEARCH('" ", opt) 3027 spaceIndex => 3028 commandString := stripSpaces SUBSEQ(opt, 0, spaceIndex) 3029 argString := stripSpaces SUBSEQ(opt, spaceIndex) 3030 command := tokTran commandString 3031 pform := parseFromString argString 3032 [command, pform] 3033 [tokTran tok for tok in dumbTokenize opt] 3034 3035handleTokensizeSystemCommands(unabr, optionList) == 3036 optionList := [dumbTokenize opt for opt in optionList] 3037 parcmd := [[tokTran tok for tok in opt] for opt in optionList] 3038 parcmd => tokenSystemCommand(unabr, parcmd) 3039 3040getFirstWord string == 3041 spaceIndex := SEARCH('" ", string) 3042 null spaceIndex => string 3043 stripSpaces SUBSEQ(string, 0, spaceIndex) 3044 3045ltrace l == trace l 3046 3047--------------------> NEW DEFINITION (see intint.lisp) 3048stripSpaces str == 3049 STRING_-TRIM([char '" "], str) 3050 3051npProcessSynonym(str) == 3052 if str = '"" then printSynonyms(NIL) 3053 else 3054 pair := processSynonymLine str 3055 if $CommandSynonymAlist then 3056 PUTALIST($CommandSynonymAlist, first pair, rest pair) 3057 else $CommandSynonymAlist := [pair] 3058 terminateSystemCommand() 3059 3060InterpExecuteSpadSystemCommand string == 3061 CATCH("coerceFailure", 3062 CATCH("SPAD_READER", ExecuteInterpSystemCommand string) ) 3063 3064intProcessSynonyms str == 3065 LINE:local := str 3066 processSynonyms() 3067 LINE 3068 3069ExecuteInterpSystemCommand string == 3070 string := intProcessSynonyms(string) 3071 $currentLine:local:=string 3072 string:=SUBSTRING(string,1,nil) 3073 string = '"" => nil 3074 doSystemCommand string 3075 3076parseFromString(s) == 3077 s := next(function ncloopParse, 3078 next(function lineoftoks,incString s)) 3079 StreamNull s => nil 3080 pf2Sex macroExpanded first rest first s 3081 3082ncParseFromString(s) == 3083 $BreakMode : local := 'throw_reader 3084 CATCH('SPAD_READER, parseFromString(s)) 3085