/ main.c
main.c
1 #include "listhdr.h" 2 #include "comphdr.h" 3 #include "redhdr.h" 4 #include "emas.h" 5 #include "revision" 6 #ifdef LINENOISE 7 # include "linenoise.h" 8 #endif 9 10 //---------------------------------------------------------------------- 11 //The KRC system is Copyright (c) D. A. Turner 1981 12 //All rights reserved. It is distributed as free software under the 13 //terms in the file "COPYING", which is included in the distribution. 14 //---------------------------------------------------------------------- 15 16 //#include <ctype.h> // for toupper() 17 #include <setjmp.h> 18 #include <string.h> // for strcmp() 19 #include <unistd.h> // for fork(), stat() 20 #include <sys/types.h> // for sys/wait.h, stat() 21 #include <sys/wait.h> 22 #include <sys/stat.h> 23 #include <signal.h> 24 25 // Local function declarations 26 STATIC VOID DIRCOM(), DISPLAYCOM(), QUITCOM(), OBJECTCOM(); 27 STATIC VOID RESETCOM(), GCCOM(), COUNTCOM(), SAVECOM(), FILECOM(), GETCOM(); 28 STATIC VOID LISTCOM(), NAMESCOM(), LIBCOM(), CLEARCOM(), OPENLIBCOM(); 29 STATIC VOID HELPCOM(), RENAMECOM(), ABORDERCOM(), REORDERCOM(), DELETECOM(); 30 STATIC BOOL STARTDISPLAYCOM(); 31 32 STATIC VOID PARSELINE(char *line); 33 STATIC VOID INITIALISE(); 34 STATIC VOID ENTERARGV(int USERARGC, LIST USERARGV); 35 STATIC VOID SETUP_COMMANDS(); 36 STATIC VOID COMMAND(); 37 STATIC VOID DISPLAYALL(BOOL DOUBLESPACING); 38 STATIC BOOL MAKESURE(); 39 STATIC VOID FILENAME(); 40 STATIC BOOL OKFILE(FILE *STR, char *FILENAME); 41 STATIC VOID CHECK_HITS(); 42 STATIC BOOL GETFILE(char *FILENAME); 43 STATIC VOID FIND_UNDEFS(); 44 STATIC BOOL ISDEFINED(ATOM X); 45 STATIC VOID SCRIPTLIST(LIST S); 46 STATIC LIST SUBST(LIST Z,LIST A); 47 STATIC VOID NEWEQUATION(); 48 STATIC VOID CLEARMEMORY(); 49 STATIC VOID COMMENT(); 50 STATIC VOID EVALUATION(); 51 STATIC LIST SORT(LIST X); 52 STATIC VOID SCRIPTREORDER(); 53 STATIC WORD NO_OF_EQNS(ATOM A); 54 STATIC BOOL PROTECTED(ATOM A); 55 STATIC BOOL PRIMITIVE(ATOM A); 56 STATIC VOID REMOVE(ATOM A); 57 STATIC LIST EXTRACT(ATOM A, ATOM B); 58 59 STATIC LIST COMMANDS=NIL, SCRIPT=NIL, OUTFILES=NIL; //BASES 60 STATIC ATOM LASTFILE=0; //BASES 61 62 STATIC LIST LIBSCRIPT=NIL, HOLDSCRIPT=NIL, GET_HITS=NIL; //BASES 63 STATIC BOOL SIGNOFF=FALSE, SAVED=TRUE, EVALUATING=FALSE; 64 STATIC BOOL ATOBJECT=FALSE, ATCOUNT=FALSE; //FLAGS USED IN DEBUGGING SYSTEM 65 STATIC char PARAMV[256]; // FOR CALLING EMAS 66 67 // Global variables owned by main.c 68 WORD LEGACY=FALSE; //set by -z option 69 LIST FILECOMMANDS = NIL; 70 BOOL SKIPCOMMENTS; //SET BY -s OPTION 71 char *USERLIB=NULL; //SET BY -l OPTION 72 73 // Local variables 74 STATIC BOOL FORMATTING; // Are we evaluating with '?' ? 75 76 STATIC BOOL QUIET = FALSE; // Suppress greetings, prompts etc.? 77 STATIC char *EVALUATE = NULL; // Expression to execute in batch mode 78 79 // INITIALISATION AND STEERING 80 81 VOID ESCAPETONEXTCOMMAND(); 82 83 // Are we ignoring interrupts? 84 static BOOL INTERRUPTS_ARE_HELD = FALSE; 85 // Was an interrupt delivered while we were ignoring them? 86 static BOOL INTERRUPT_OCCURRED = FALSE; 87 88 STATIC VOID 89 CATCHINTERRUPT(int signum) 90 { IF INTERRUPTS_ARE_HELD DO { 91 INTERRUPT_OCCURRED = signum; // Can't be 0 92 RETURN 93 } 94 FIXUP_S(); //IN CASE INTERRUPT STRUCK WHILE REDUCE 95 //WAS DISSECTING A CONSTANT 96 _WRCH=TRUEWRCH; 97 CLOSECHANNELS(); 98 UNLESS QUIET || ABORTED // die quietly if running as script or ABORT() called 99 DO //WRITES("\n**break in - return to KRC command level**\n"); 100 WRITES("<interrupt>\n"); 101 ABORTED=FALSE; 102 ESCAPETONEXTCOMMAND(); } 103 104 105 VOID 106 HOLD_INTERRUPTS() { INTERRUPTS_ARE_HELD = TRUE; } 107 108 VOID 109 RELEASE_INTERRUPTS() 110 { INTERRUPTS_ARE_HELD = FALSE; 111 IF INTERRUPT_OCCURRED DO { 112 INTERRUPT_OCCURRED=FALSE; 113 CATCHINTERRUPT(INTERRUPT_OCCURRED); 114 } } 115 116 //ESSENTIAL THAT DEFINITIONS OF THE ABOVE SHOULD BE PROVIDED IF 117 //THE PACKAGE IS TO BE USED IN AN INTERACTIVE PROGRAM 118 119 // Where to jump back to on runtime errors or keyboard interrupts 120 static jmp_buf nextcommand; 121 122 VOID ESCAPETONEXTCOMMAND() 123 { _WRCH=TRUEWRCH; 124 IF INPUT()!=SYSIN DO { ENDREAD() ; SELECTINPUT(SYSIN); } 125 CLOSECHANNELS(); 126 IF EVALUATING 127 DO { IF ATCOUNT DO OUTSTATS(); 128 CLEARMEMORY(); //IN CASE SOME POINTERS HAVE BEEN LEFT REVERSED 129 EVALUATING=FALSE; } 130 IF HOLDSCRIPT!=NIL 131 DO { SCRIPT=HOLDSCRIPT, HOLDSCRIPT=NIL; 132 CHECK_HITS(); } 133 INIT_CODEV(); 134 INIT_ARGSPACE(); 135 longjmp(nextcommand, 1); } 136 137 // Buffer for signal handling 138 static struct sigaction act; // All initialised to 0/NULL is fine. 139 140 VOID 141 GO() 142 { // STACKLIMIT:= @V4 + 30000 //IMPLEMENTATION DEPENDENT,TO TEST FOR RUNAWAY RECURSION 143 IF setjmp(nextcommand) == 0 DO 144 { // First-time initialization 145 INIT_CODEV(); 146 INIT_ARGSPACE(); 147 INITIALISE(); 148 // Set up the interrupt handler 149 act.sa_handler = CATCHINTERRUPT; 150 act.sa_flags = SA_NODEFER; // Bcos the interrupt handler never returns 151 sigaction(SIGINT, &act, NULL); 152 } else { 153 // When the GC is called from CONS() from the depths of an 154 // evaluation, it is more likely that stale pointers left in 155 // registers, either still in them or saved on the stack, 156 // will cause now-unused areas of the heap to be preserved. 157 // We mitigate this by calling the GC here, after an interrupt 158 // or an out-of-space condition, when the stack is shallow and 159 // the registers are less likely to contain values pointing 160 // inside the CONS space. 161 BOOL HOLDATGC=ATGC; ATGC=FALSE; 162 FORCE_GC(); 163 ATGC=HOLDATGC; 164 } 165 // Both initially and on longjump, continue here. 166 IF EVALUATE && !SIGNOFF DO { 167 SIGNOFF=TRUE; // Quit on errors or interrupts 168 PARSELINE(EVALUATE); 169 TEST EXPFLAG THEN EVALUATION(); OR 170 WRITES("-e takes an expression followed by ? or !\n"); 171 IF ERRORFLAG 172 DO SYNTAX_ERROR("malformed expression after -e\n"); 173 } 174 UNTIL SIGNOFF DO COMMAND(); 175 QUITCOM(); 176 // FINISH //moved inside QUITCOM() 177 } 178 179 180 // PARSELINE: A version of READLINE that gets its input from a string 181 182 static char *input_line; 183 184 // Alternative version of RDCH that gets its chars from a string 185 static int 186 str_RDCH(void) 187 { 188 IF input_line==NULL DO RESULTIS EOF; 189 IF *input_line=='\0' DO { input_line=NULL; 190 RESULTIS '\n'; } 191 RESULTIS *input_line++; 192 } 193 194 static int 195 str_UNRDCH(int c) 196 { 197 TEST input_line==NULL && c=='\n' 198 THEN input_line="\n"; 199 OR *(--input_line)=c; 200 RESULTIS c; 201 } 202 203 // SAME AS READLINE, BUT GETS ITS INPUT FROM A C STRING 204 STATIC VOID 205 PARSELINE(char *line) 206 { input_line=line; 207 _RDCH=str_RDCH, _UNRDCH=str_UNRDCH; 208 READLINE(); 209 _RDCH=bcpl_RDCH, _UNRDCH=bcpl_UNRDCH; 210 } 211 212 // ----- END OF PARSELINE 213 214 STATIC char TITLE[] = "Kent Recursive Calculator 1.0"; 215 216 // Where to look for "prelude" and other files KRC needs 217 #ifndef LIBDIR 218 #define LIBDIR "/usr/lib/krc" 219 #endif 220 //but use krclib in current directory if present, see below 221 222 STATIC VOID 223 INITIALISE() 224 { BOOL LOADPRELUDE=TRUE; // Do we need to read the prelude? 225 BOOL OLDLIB=FALSE; // Use legacy prelude? 226 char *USERSCRIPT=NULL; // Script given on command line 227 LIST USERARGV=NIL; // Reversed list of args after script name 228 int USERARGC=0; // How many items in USERARGV? 229 // BOOL LISTSCRIPT=FALSE; // List the script as we read it? 230 int I; 231 232 IF !isatty(0) DO QUIET=TRUE; 233 234 SETUP_PRIMFNS_ETC(); 235 FOR (I=1; I<ARGC; I++) { 236 TEST ARGV[I][0]=='-' THEN 237 SWITCHON ARGV[I][1] INTO { 238 CASE 'n': LOADPRELUDE=FALSE; 239 ENDCASE 240 CASE 's': SKIPCOMMENTS=TRUE; 241 ENDCASE 242 CASE 'c': ATCOUNT=TRUE; ENDCASE 243 CASE 'o': ATOBJECT=TRUE; ENDCASE 244 CASE 'd': // Handled in listpack.c 245 CASE 'l': // Handled in listpack.c 246 CASE 'h': ++I; // Handled in listpack.c 247 CASE 'g': // Handled in listpack.c 248 ENDCASE 249 CASE 'e': IF ++I>=ARGC || ARGV[I][0] == '-' 250 DO { WRITES("krc: -e What?\n"); FINISH } 251 IF EVALUATE 252 DO { WRITES("krc: Only one -e flag allowed\n"); FINISH } 253 EVALUATE=ARGV[I]; 254 QUIET=TRUE; 255 ENDCASE 256 case 'z': LISTBASE=1; 257 LEGACY=TRUE; 258 WRITES("LISTBASE=1\n"); 259 ENDCASE 260 case 'L': OLDLIB=1; ENDCASE 261 // case 'v': LISTSCRIPT=TRUE; ENDCASE 262 // Other parameters may be detected using HAVEPARAM() 263 case 'C': case 'N': case 'O': //used only by testcomp, disabled 264 DEFAULT: WRITEF("krc: invalid option -%c\n",ARGV[I][1]); 265 FINISH 266 ENDCASE 267 } OR { 268 // Filename of script to load, or arguments for script 269 IF USERSCRIPT==NULL DO USERSCRIPT=ARGV[I]; //was TEST...OR 270 USERARGV=CONS((LIST)MKATOM(ARGV[I]), USERARGV), USERARGC++; 271 } } 272 TEST EVALUATE THEN ENTERARGV(USERARGC, USERARGV); 273 OR IF USERARGC>1 DO { WRITES("krc: too many arguments\n"); FINISH } 274 TEST LOADPRELUDE THEN 275 TEST USERLIB THEN GETFILE(USERLIB); //-l option was used 276 OR { struct stat buf; 277 TEST stat("krclib",&buf)==0 278 THEN GETFILE(OLDLIB?"krclib/lib1981":"krclib/prelude"); 279 OR GETFILE(OLDLIB?LIBDIR "/lib1981":LIBDIR "/prelude"); } 280 OR // TEST USERLIB || OLDLIB THEN 281 // { WRITES("krc: invalid combination -n and -l or -L\n"); FINISH } OR 282 WRITES("\"PRELUDE\" suppressed\n"); 283 SKIPCOMMENTS=FALSE; //effective only for prelude 284 LIBSCRIPT=SORT(SCRIPT),SCRIPT=NIL; 285 IF USERSCRIPT DO { 286 // IF LISTSCRIPT DO _RDCH=echo_RDCH; 287 GETFILE(USERSCRIPT); 288 SAVED=TRUE; 289 // IF LISTSCRIPT DO _RDCH=bcpl_RDCH; 290 LASTFILE=MKATOM(USERSCRIPT); 291 } 292 SETUP_COMMANDS(); 293 RELEASE_INTERRUPTS(); 294 IF !QUIET DO WRITEF("%s\nrevised %s\n%s\n",TITLE,revision, 295 // "http://krc-lang.org", 296 "/h for help"); 297 } 298 299 // Given the (reverse-order) list of atoms made from command-line arguments 300 // supplied after the name of the script file, create their an entry in the 301 // script called "argv" for the krc program to access them. 302 // We create it as a list of strings (i.e. a list of atoms) for which 303 // the code for a three-element list of string is: 304 // ( (0x0.NIL). :- 0 parameters, no comment 305 // ( 0. :- memo field unset 306 // LOAD.(QUOTE."one").LOAD.(QUOTE."two").LOAD.(QUOTE."three"). 307 // FORMLIST.0x03.STOP.NIL ). 308 // NIL ) 309 STATIC VOID 310 ENTERARGV(int USERARGC, LIST USERARGV) 311 { 312 ATOM A=MKATOM("argv"); 313 LIST CODE=CONS((LIST)FORMLIST_C, 314 CONS((LIST)USERARGC, 315 CONS((LIST)STOP_C, NIL))); 316 FOR ( ;USERARGV != NIL; USERARGV=TL(USERARGV)) 317 CODE=CONS((LIST)LOAD_C, 318 CONS(CONS((LIST)QUOTE, HD(USERARGV)),CODE)); 319 VAL(A) = CONS(CONS((LIST)0, NIL), 320 CONS(CONS((LIST)0,CODE), 321 NIL)); 322 ENTERSCRIPT(A); 323 } 324 325 VOID 326 SPACE_ERROR(char *MESSAGE) 327 { _WRCH=TRUEWRCH; 328 CLOSECHANNELS(); 329 TEST EVALUATING 330 THEN { WRITEF("\n**%s**\n**evaluation abandoned**\n",MESSAGE); 331 ESCAPETONEXTCOMMAND(); } OR 332 TEST MEMORIES==NIL 333 THEN 334 { WRITEF("\n%s - recovery impossible\n", MESSAGE); 335 FINISH } 336 OR CLEARMEMORY(); //LET GO OF MEMOS AND TRY TO CARRY ON 337 } 338 339 VOID 340 BASES(VOID (*F)(LIST *)) { 341 extern LIST S; // In reducer.c 342 F(&COMMANDS); 343 F(&FILECOMMANDS); 344 F(&SCRIPT); 345 F(&LIBSCRIPT); 346 F(&HOLDSCRIPT); 347 F(&GET_HITS); 348 F((LIST *)&LASTFILE); 349 F(&OUTFILES); 350 F(&MEMORIES); 351 F(&S); 352 F(&TOKENS); 353 F((LIST *)&THE_ID); 354 F(&THE_CONST); 355 F(&LASTLHS); 356 F(&TRUTH); 357 F(&FALSITY); 358 F(&INFINITY); 359 COMPILER_BASES(F); 360 REDUCER_BASES(F); 361 } 362 363 STATIC VOID 364 SETUP_COMMANDS() 365 { 366 #define F(S,R) { COMMANDS=CONS(CONS((LIST)MKATOM(S),(LIST)R),COMMANDS); } 367 #define FF(S,R) { FILECOMMANDS=CONS((LIST)MKATOM(S),FILECOMMANDS); F(S,R); } 368 F("delete",DELETECOM); 369 F("d",DELETECOM); //SYNONYM 370 F("reorder",REORDERCOM); 371 FF("save",SAVECOM); 372 FF("get",GETCOM); 373 FF("list",LISTCOM); 374 FF("file",FILECOM); 375 FF("f",FILECOM); 376 F("dir",DIRCOM); 377 F("quit",QUITCOM); 378 F("q",QUITCOM); //SYNONYM 379 F("names",NAMESCOM); 380 F("lib",LIBCOM); 381 F("aborder",ABORDERCOM); 382 F("rename",RENAMECOM); 383 F("openlib",OPENLIBCOM); 384 F("clear",CLEARCOM); 385 F("help",HELPCOM); 386 F("h",HELPCOM); //SYNONYM 387 F("object",OBJECTCOM); //THESE LAST COMMANDS ARE FOR USE IN 388 F("reset",RESETCOM); //DEBUGGING THE SYSTEM 389 F("gc",GCCOM); 390 F("dic",REPORTDIC); 391 F("count",COUNTCOM); 392 F("lpm",LISTPM); 393 #undef FF 394 #undef F 395 } 396 397 STATIC VOID 398 DIRCOM() 399 { int status; 400 switch (fork()) { 401 case 0: execlp("ls", "ls", NULL); break; 402 case -1: break; 403 default: wait(&status); 404 } } 405 406 VOID 407 CLOSECHANNELS() 408 { IF !EVALUATING && OUTPUT()!=SYSOUT DO ENDWRITE(); 409 UNTIL OUTFILES==NIL 410 DO { SELECTOUTPUT((FILE *)TL(HD(OUTFILES))); 411 IF FORMATTING DO NEWLINE(); 412 ENDWRITE(); 413 OUTFILES=TL(OUTFILES); } 414 SELECTOUTPUT(SYSOUT); 415 } 416 417 FILE * 418 FINDCHANNEL(char *F) 419 { LIST P=OUTFILES; 420 UNTIL P==NIL || strcmp((char *)HD(HD(P)),F) == 0 421 DO P=TL(P); 422 TEST P==NIL 423 THEN { FILE *OUT = FINDOUTPUT(F); 424 IF OUT != NULL 425 DO OUTFILES=CONS(CONS((LIST)F,(LIST)OUT),OUTFILES); 426 RESULTIS OUT; } 427 OR RESULTIS (FILE *)TL(HD(P)); 428 } 429 430 // COMMAND INTERPRETER 431 // EACH COMMAND IS TERMINATED BY A NEWLINE 432 // <COMMAND>::= /<EMPTY> | (DISPLAYS WHOLE SCRIPT) 433 // /DELETE <THINGY>* | 434 // (IF NO <THINGY>'S ARE SPECIFIED IT DELETES WHOLE SCRIPT) 435 // /DELETE <NAME> <PART>* | 436 // /REORDER <THINGY>* | 437 // /REORDER <NAME> <PART>* | 438 // /ABORDER | 439 // /SAVE "<FILENAME>" | 440 // /GET "<FILENAME>" | 441 // /LIST "<FILENAME>" | 442 // /FILE | 443 // /QUIT | 444 // /NAMES | 445 // /OPEN| 446 // /CLEAR | 447 // /LIB | 448 // <NAME> | (DISPLAYS EQNS FOR THIS NAME) 449 // <NAME> .. <NAME> | (DISPLAYS A SECTION OF THE SCRIPT) 450 // <EXP>? | (EVALUATE AND PRINT) 451 // <EXP>! | (SAME BUT WITH UNFORMATTED PRINTING) 452 // <EQUATION> (ADD TO SCRIPT) 453 // <THINGY> ::= <NAME> | <NAME> .. <NAME> | <NAME> .. 454 // <PART> ::= <INT> | <INT>..<INT> | <INT>.. 455 456 //STATIC char *HELP[] = { //replaced by HELPCOM() see below 457 //"/ Displays the whole script", 458 //"/delete NAMES Deletes the named functions. /d deletes everything", 459 //"/delete NAME PARTS Deletes the numbered equations from function NAME", 460 //"/reorder NAME NAMES Moves the equations for NAMES after those for NAME", 461 //"/reorder NAME PARTS Redefines the order of NAME's equations", 462 //"/aborder Sorts the script into alphabetical order", 463 //"/rename FROMs,TOs Changes the names of one or more functions", 464 //"/save FILENAME Saves the script in the named file", 465 //"/get FILENAME Adds the contents of a file to the script", 466 //"/list FILENAME Displays the contents of a disk file", 467 //"/file (or /f) Shows the current default filename", 468 //"/file FILENAME Changes the default filename", 469 //"/dir List filenames in current directory/folder", 470 //"/quit (or /q) Ends this KRC session", 471 //"/names Displays the names defined in your script", 472 //"/openlib Allows you to modify equations in the prelude/library", 473 //"/clear Clears the memo fields for all variables", 474 //"/lib Displays the names defined in the prelude/library", 475 //"NAME Displays the equations defined for the function NAME", 476 //"NAME..NAME Displays a section of the script", 477 //"EXP? Evaluates an expression and pretty-print the result", 478 //"EXP! The same but with unformatted output", 479 //"EQUATION Adds an equation to the script", 480 //" NAMES ::= NAME | NAME..NAME | NAME.. PARTS ::= INT | INT..INT | INT..", 481 //NULL, 482 //}; 483 // 484 //STATIC VOID 485 //SHOWHELP() 486 //{ 487 // char **h; 488 // for (h=HELP; *h; h++) printf("%s\n", *h); 489 //} 490 491 #define KRCPAGER "less -F -X -P'%F (press q to quit)' " 492 #define HELPLOCAL KRCPAGER "krclib/help/" 493 #define HELP KRCPAGER LIBDIR "/help/" 494 #define BUFLEN 80 495 496 STATIC VOID 497 HELPCOM() 498 { struct stat buf; 499 char strbuf[BUFLEN+1],*topic; 500 int local=stat("krclib",&buf)==0,r; 501 TEST HAVE(EOL) 502 THEN { TEST local 503 THEN r=system(HELPLOCAL "menu"); 504 OR r=system(HELP "menu"); 505 RETURN } 506 topic = HAVEID()?PRINTNAME(THE_ID):NULL; 507 UNLESS topic && HAVE(EOL) 508 DO { WRITES("/h What? `/h' for options\n"); 509 RETURN } 510 strncpy(strbuf,local?HELPLOCAL:HELP,BUFLEN); 511 strncat(strbuf,topic,BUFLEN-strlen(strbuf)); 512 r=system(strbuf); } 513 514 STATIC VOID 515 COMMAND() 516 { 517 static char prompt[]="krc> "; 518 #ifdef LINENOISE 519 char *line=linenoise(QUIET ? "" : prompt); 520 if (line && line[0] == '\0') return; // Otherwise the interpreter exits 521 PARSELINE(line); // Handles NULL->EOF OK 522 IF HAVE(EOL) DO { free(line); RETURN } //IGNORE BLANK LINES 523 if (line) { 524 linenoiseHistoryAdd(line); 525 free(line); 526 } 527 #else 528 IF !QUIET DO PROMPT(prompt); // ON EMAS PROMPTS REMAIN IN EFFECT UNTIL CANCELLED 529 READLINE(); 530 IF HAVE(EOL) DO RETURN //IGNORE BLANK LINES 531 SUPPRESSPROMPTS(); // CANCEL PROMPT (IN CASE COMMAND READS DATA) 532 #endif 533 TEST HAVE((TOKEN)EOF) 534 THEN SIGNOFF=TRUE; OR 535 TEST HAVE((TOKEN)'/') 536 THEN TEST HAVE(EOL) 537 THEN DISPLAYALL(FALSE); OR 538 // TEST HAVE((TOKEN)'@') && HAVE(EOL) 539 // THEN LISTPM(); OR //FOR DEBUGGING THE SYSTEM 540 { LIST P=COMMANDS; 541 TEST HAVEID() 542 THEN THE_ID=MKATOM(SCASECONV(PRINTNAME(THE_ID))); 543 //ALWAYS ACCEPT COMMANDS IN EITHER CASE 544 OR P=NIL; 545 UNTIL P==NIL || THE_ID==(ATOM)HD(HD(P)) DO P=TL(P); 546 TEST P==NIL 547 THEN //SHOWHELP(); 548 WRITES("command not recognised\nfor help type /h\n"); 549 OR ((void (*)())TL(HD(P)))(); // SEE "SETUP_COMMANDS()" 550 } OR 551 TEST STARTDISPLAYCOM() THEN DISPLAYCOM(); OR 552 TEST COMMENTFLAG>0 THEN COMMENT(); OR 553 TEST EQNFLAG THEN NEWEQUATION(); 554 OR EVALUATION(); 555 IF ERRORFLAG DO SYNTAX_ERROR("**syntax error**\n"); 556 } 557 558 STATIC BOOL 559 STARTDISPLAYCOM() 560 { LIST HOLD=TOKENS; 561 WORD R=HAVEID() && (HAVE(EOL) || HAVE((TOKEN)DOTDOT_SY)); 562 TOKENS=HOLD; 563 RESULTIS R; 564 } 565 566 STATIC VOID 567 DISPLAYCOM() 568 { TEST HAVEID() 569 THEN TEST HAVE(EOL) 570 THEN DISPLAY(THE_ID,TRUE,FALSE); OR 571 TEST HAVE((TOKEN)DOTDOT_SY) 572 THEN { ATOM A = THE_ID; LIST X=NIL; 573 ATOM B = HAVE(EOL) ? (ATOM)EOL : // BUG? 574 HAVEID() && HAVE(EOL) ? THE_ID : 575 0; 576 TEST B==0 THEN SYNTAX(); 577 OR X=EXTRACT(A,B); 578 UNTIL X==NIL 579 DO { DISPLAY((ATOM)HD(X),FALSE,FALSE); 580 X=TL(X); } } //could insert extra line here between groups 581 OR SYNTAX(); 582 OR SYNTAX(); 583 } 584 585 STATIC VOID 586 DISPLAYALL(BOOL DOUBLESPACING) // "SCRIPT" IS A LIST OF ALL USER DEFINED 587 // NAMES IN ALPHABETICAL ORDER 588 { LIST P=SCRIPT; 589 IF P==NIL DO WRITES("Script=empty\n"); 590 UNTIL P==NIL DO { UNLESS PRIMITIVE((ATOM)HD(P)) 591 //don't display builtin fns (relevant only in /openlib) 592 DO DISPLAY((ATOM)HD(P),FALSE,FALSE); 593 P=TL(P); 594 IF DOUBLESPACING && P != NIL 595 //extra line between groups 596 DO NEWLINE(); } 597 } 598 599 STATIC BOOL 600 PRIMITIVE(ATOM A) 601 { IF TL(VAL(A))==NIL DO RESULTIS FALSE; //A has comment but no eqns 602 RESULTIS HD(TL(HD(TL(VAL(A)))))==(LIST)CALL_C; } 603 604 STATIC VOID 605 QUITCOM() 606 { IF TOKENS!=NIL DO CHECK(EOL); 607 IF ERRORFLAG DO RETURN 608 IF MAKESURE() 609 DO { WRITES("krc logout\n"); 610 FINISH } 611 } 612 613 STATIC BOOL 614 MAKESURE() 615 { IF SAVED || SCRIPT==NIL DO RESULTIS TRUE; 616 WRITES("Are you sure? "); 617 { WORD CH=RDCH(), C; 618 UNRDCH(CH); 619 UNTIL (C=RDCH())=='\n' || C == EOF DO LOOP 620 IF CH=='y' || CH=='Y' DO RESULTIS TRUE; 621 WRITES("Command ignored\n"); 622 RESULTIS FALSE; 623 } } 624 625 STATIC VOID 626 OBJECTCOM() 627 { ATOBJECT=TRUE; } 628 629 STATIC VOID 630 RESETCOM() 631 { ATOBJECT=FALSE,ATCOUNT=FALSE,ATGC=FALSE; } 632 633 STATIC VOID 634 GCCOM() 635 { ATGC=TRUE; 636 FORCE_GC(); } 637 638 STATIC VOID 639 COUNTCOM() 640 { ATCOUNT=TRUE; } 641 642 STATIC VOID 643 SAVECOM() 644 { FILENAME(); 645 IF ERRORFLAG DO RETURN 646 IF SCRIPT==NIL 647 DO { WRITES("Cannot save empty script\n"); 648 RETURN } 649 { 650 FILE *OUT = FINDOUTPUT("T#SCRIPT"); 651 SELECTOUTPUT(OUT); 652 DISPLAYALL(TRUE); 653 ENDWRITE(); 654 SELECTOUTPUT(SYSOUT); 655 // Copy T#SCRIPT back to the save file. 656 { int status; 657 switch (fork()) { 658 case 0: execlp("mv", "mv", "T#SCRIPT", PRINTNAME(THE_ID), (char *)0); 659 default: wait(&status); 660 if (status == 0) SAVED=TRUE; 661 else /* Drop into... */ 662 case -1: WRITES("File saved in T#SCRIPT.\n"); break; 663 break; 664 } } } } 665 666 STATIC VOID 667 FILENAME() 668 { TEST HAVE(EOL) 669 THEN TEST LASTFILE==0 670 THEN { WRITES("(No file set)\n") ; SYNTAX(); } 671 OR THE_ID=LASTFILE; 672 OR TEST HAVEID() && HAVE(EOL) 673 THEN LASTFILE=THE_ID; 674 OR { IF HAVECONST() && HAVE(EOL) && !ISNUM(THE_CONST) 675 DO WRITES("(Warning - quotation marks no longer expected around filenames in file commands - DT, Nov 81)\n"); 676 SYNTAX(); } 677 } 678 679 STATIC VOID 680 FILECOM() 681 { TEST HAVE(EOL) 682 THEN TEST LASTFILE==0 683 THEN WRITES("No files used\n"); 684 OR WRITEF("File = %s\n",PRINTNAME(LASTFILE)); 685 OR FILENAME(); 686 } 687 688 STATIC BOOL 689 OKFILE(FILE *STR, char *FILENAME) 690 { IF STR!=NULL DO RESULTIS TRUE; 691 WRITEF("Cannot open \"%s\"\n",FILENAME); 692 RESULTIS FALSE; } 693 694 STATIC VOID 695 GETCOM() 696 { BOOL CLEAN = SCRIPT==NIL; 697 FILENAME(); 698 IF ERRORFLAG DO RETURN 699 HOLDSCRIPT=SCRIPT,SCRIPT=NIL,GET_HITS=NIL; 700 GETFILE(PRINTNAME(THE_ID)); 701 CHECK_HITS(); 702 SCRIPT=APPEND(HOLDSCRIPT,SCRIPT),SAVED=CLEAN,HOLDSCRIPT=NIL; 703 } 704 705 STATIC VOID 706 CHECK_HITS() 707 { UNLESS GET_HITS==NIL 708 DO { WRITES("Warning - /get has overwritten or modified:\n"); 709 SCRIPTLIST(REVERSE(GET_HITS)); 710 GET_HITS=NIL; } 711 } 712 713 STATIC BOOL 714 GETFILE(char *FILENAME) 715 { FILE *IN = FINDINPUT(FILENAME); 716 UNLESS OKFILE(IN,FILENAME) DO RESULTIS FALSE; 717 SELECTINPUT(IN); 718 { int line=0; //to locate line number of error in file 719 do{line++; 720 READLINE(); 721 IF ferror(IN) DO { 722 ERRORFLAG=TRUE; 723 BREAK; 724 } 725 IF HAVE(EOL) DO LOOP; 726 IF HD(TOKENS)==ENDSTREAMCH 727 DO BREAK 728 TEST COMMENTFLAG 729 THEN { line+=(COMMENTFLAG-1); 730 COMMENT(); } 731 OR NEWEQUATION(); 732 IF ERRORFLAG 733 DO { SYNTAX_ERROR("**syntax error in file "); 734 WRITEF("%s at line %d\n",FILENAME,line); } 735 } REPEAT 736 ENDREAD(); 737 SELECTINPUT(SYSIN); 738 LASTLHS=NIL; 739 RESULTIS TRUE; }} 740 741 STATIC VOID 742 LISTCOM() 743 { FILENAME(); 744 IF ERRORFLAG DO RETURN 745 { char *FNAME=PRINTNAME(THE_ID); 746 FILE *IN=FINDINPUT(FNAME); 747 UNLESS OKFILE(IN,FNAME) DO RETURN 748 SELECTINPUT(IN); 749 { WORD CH=RDCH(); 750 UNTIL CH==EOF 751 DO { WRCH(CH); CH=RDCH(); } 752 ENDREAD(); 753 SELECTINPUT(SYSIN); 754 } } } 755 756 STATIC VOID 757 NAMESCOM() 758 { CHECK(EOL); 759 IF ERRORFLAG DO RETURN 760 TEST SCRIPT==NIL 761 THEN DISPLAYALL(FALSE); 762 OR { SCRIPTLIST(SCRIPT); FIND_UNDEFS(); } 763 } 764 765 STATIC VOID 766 FIND_UNDEFS() //SEARCHES THE SCRIPT FOR NAMES USED BUT NOT DEFINED 767 { LIST S=SCRIPT, UNDEFS=NIL; 768 UNTIL S==NIL 769 DO { LIST EQNS = TL(VAL((ATOM)HD(S))); 770 UNTIL EQNS==NIL 771 DO { LIST CODE = TL(HD(EQNS)); 772 WHILE ISCONS(CODE) 773 DO { LIST A = HD(CODE); 774 IF ISATOM(A) && !ISDEFINED((ATOM)A) && !MEMBER(UNDEFS,A) 775 DO UNDEFS=CONS(A,UNDEFS); 776 CODE=TL(CODE); } 777 EQNS=TL(EQNS); } 778 S=TL(S); } 779 UNLESS UNDEFS==NIL 780 DO { WRITES("\nNames used but not defined:\n"); 781 SCRIPTLIST(REVERSE(UNDEFS)); } 782 } 783 784 STATIC BOOL 785 ISDEFINED(ATOM X) 786 { RESULTIS VAL(X)==NIL||TL(VAL(X))==NIL ? FALSE : TRUE; } 787 788 STATIC VOID 789 LIBCOM() 790 { CHECK(EOL); 791 IF ERRORFLAG DO RETURN 792 TEST LIBSCRIPT==NIL 793 THEN WRITES("library = empty\n"); 794 OR SCRIPTLIST(LIBSCRIPT); } 795 796 STATIC VOID 797 CLEARCOM() 798 { CHECK(EOL); 799 IF ERRORFLAG DO RETURN 800 CLEARMEMORY(); } 801 802 STATIC VOID 803 SCRIPTLIST(LIST S) 804 { WORD COL=0,I=0; 805 #define LINEWIDTH 68 //THE MINIMUM OF VARIOUS DEVICES 806 UNTIL S==NIL 807 DO { char *N = PRINTNAME((ATOM)HD(S)); 808 IF PRIMITIVE((ATOM)HD(S)) DO {S=TL(S); LOOP} 809 COL=COL+strlen(N)+1; 810 IF COL>LINEWIDTH 811 DO { COL=0 ; NEWLINE(); } 812 WRITES(N); 813 WRCH(' '); 814 I=I+1,S=TL(S); } 815 IF COL+6>LINEWIDTH DO NEWLINE(); 816 WRITEF(" (%" W ")\n",I); 817 } 818 819 STATIC VOID 820 OPENLIBCOM() 821 { CHECK(EOL); 822 IF ERRORFLAG DO RETURN 823 SAVED=SCRIPT==NIL; 824 SCRIPT=APPEND(SCRIPT,LIBSCRIPT); 825 LIBSCRIPT=NIL; 826 } 827 828 STATIC VOID 829 RENAMECOM() 830 { LIST X=NIL,Y=NIL,Z=NIL; 831 WHILE HAVEID() DO X=CONS((LIST)THE_ID,X); 832 CHECK((TOKEN)','); 833 WHILE HAVEID() DO Y=CONS((LIST)THE_ID,Y); 834 CHECK(EOL); 835 IF ERRORFLAG DO RETURN 836 { //FIRST CHECK LISTS ARE OF SAME LENGTH 837 LIST X1=X,Y1=Y; 838 UNTIL X1==NIL||Y1==NIL DO Z=CONS(CONS(HD(X1),HD(Y1)),Z),X1=TL(X1),Y1=TL(Y1); 839 UNLESS X1==NIL && Y1==NIL && Z!=NIL DO { SYNTAX(); RETURN } } 840 { // NOW CHECK LEGALITY OF RENAME 841 LIST Z1=Z,POSTDEFS=NIL,DUPS=NIL; 842 UNTIL Z1==NIL 843 DO { IF MEMBER(SCRIPT,HD(HD(Z1))) 844 DO POSTDEFS=CONS(TL(HD(Z1)),POSTDEFS); 845 IF ISDEFINED((ATOM)TL(HD(Z1))) && (!MEMBER(X,TL(HD(Z1))) || !MEMBER(SCRIPT,TL(HD(Z1))) ) 846 DO POSTDEFS=CONS(TL(HD(Z1)),POSTDEFS); 847 Z1=TL(Z1); } 848 UNTIL POSTDEFS==NIL 849 DO { IF MEMBER(TL(POSTDEFS),HD(POSTDEFS)) && 850 !MEMBER(DUPS,HD(POSTDEFS)) DO DUPS=CONS(HD(POSTDEFS),DUPS); 851 POSTDEFS=TL(POSTDEFS); } 852 UNLESS DUPS==NIL 853 DO { WRITES("/rename illegal because of conflicting uses of "); 854 UNTIL DUPS==NIL 855 DO { WRITES(PRINTNAME((ATOM)HD(DUPS))); 856 WRCH(' '); 857 DUPS=TL(DUPS); } 858 NEWLINE(); 859 RETURN } } 860 HOLD_INTERRUPTS(); 861 CLEARMEMORY(); 862 //PREPARE FOR ASSIGNMENT TO VAL FIELDS 863 { LIST X1=X,XVALS=NIL,TARGETS=NIL; 864 UNTIL X1==NIL 865 DO { IF MEMBER(SCRIPT,HD(X1)) 866 DO XVALS=CONS(VAL((ATOM)HD(X1)),XVALS),TARGETS=CONS(HD(Y),TARGETS); 867 X1=TL(X1),Y=TL(Y); } 868 //NOW CONVERT ALL OCCURRENCES IN THE SCRIPT 869 { LIST S=SCRIPT; 870 UNTIL S==NIL 871 DO { LIST EQNS=TL(VAL((ATOM)HD(S))); 872 WORD NARGS=(WORD)HD(HD(VAL((ATOM)HD(S)))); 873 UNTIL EQNS==NIL 874 DO { LIST CODE=TL(HD(EQNS)); 875 IF NARGS>0 876 DO { LIST LHS=HD(HD(EQNS)); 877 WORD I; 878 FOR (I=2; I<=NARGS; I++) 879 LHS=HD(LHS); 880 HD(LHS)=SUBST(Z,HD(LHS)); } 881 WHILE ISCONS(CODE) 882 DO HD(CODE)=SUBST(Z,HD(CODE)),CODE=TL(CODE); 883 EQNS=TL(EQNS); } 884 IF MEMBER(X,HD(S)) DO VAL((ATOM)HD(S))=NIL; 885 HD(S)=SUBST(Z,HD(S)); 886 S=TL(S); } 887 //NOW REASSIGN VAL FIELDS 888 UNTIL TARGETS==NIL 889 DO { VAL((ATOM)HD(TARGETS))=HD(XVALS); 890 TARGETS=TL(TARGETS),XVALS=TL(XVALS); } 891 RELEASE_INTERRUPTS(); 892 } } } 893 894 STATIC LIST 895 SUBST(LIST Z,LIST A) 896 { UNTIL Z==NIL 897 DO { IF A==HD(HD(Z)) 898 DO { SAVED=FALSE; RESULTIS TL(HD(Z)); } 899 Z=TL(Z); } 900 RESULTIS A; } 901 902 STATIC VOID 903 NEWEQUATION() 904 { WORD EQNO = -1; 905 IF HAVENUM() 906 DO { EQNO=100*THE_NUM+THE_DECIMALS; 907 CHECK((TOKEN)')'); } 908 { LIST X=EQUATION(); 909 IF ERRORFLAG DO RETURN 910 { ATOM SUBJECT=(ATOM)HD(X); 911 WORD NARGS=(WORD)HD(TL(X)); 912 LIST EQN=TL(TL(X)); 913 IF ATOBJECT DO { PRINTOB(EQN) ; NEWLINE(); } 914 TEST VAL(SUBJECT)==NIL 915 THEN { VAL(SUBJECT)=CONS(CONS((LIST)NARGS,NIL),CONS(EQN,NIL)); 916 ENTERSCRIPT(SUBJECT); } OR 917 TEST PROTECTED(SUBJECT) 918 THEN RETURN OR 919 TEST TL(VAL(SUBJECT))==NIL //SUBJECT CURRENTLY DEFINED ONLY BY A COMMENT 920 THEN { HD(HD(VAL(SUBJECT)))=(LIST)NARGS; 921 TL(VAL(SUBJECT))=CONS(EQN,NIL); } OR 922 // TEST NARGS==0 //SIMPLE DEF SILENTLY OVERWRITING EXISTING EQNS - REMOVED DT 2015 923 // THEN { VAL(SUBJECT)=CONS(CONS(0,TL(HD(VAL(SUBJECT)))),CONS(EQN,NIL)); 924 // CLEARMEMORY(); } OR 925 TEST NARGS!=(WORD)HD(HD(VAL(SUBJECT))) 926 THEN { WRITEF("Wrong no of args for \"%s\"\n",PRINTNAME(SUBJECT)); 927 WRITES("Equation rejected\n"); 928 RETURN } OR 929 TEST EQNO==-1 //UNNUMBERED EQN 930 THEN { LIST EQNS=TL(VAL(SUBJECT)); 931 LIST P=PROFILE(EQN); 932 do{IF EQUAL(P,PROFILE(HD(EQNS))) 933 DO { LIST CODE=TL(HD(EQNS)); 934 TEST HD(CODE)==(LIST)LINENO_C //IF OLD EQN HAS LINE NO, 935 THEN { TL(TL(CODE))=TL(EQN); //NEW EQN INHERITS 936 HD(HD(EQNS))=HD(EQN); } 937 OR HD(EQNS)=EQN; 938 CLEARMEMORY(); 939 BREAK } 940 IF TL(EQNS)==NIL 941 DO { TL(EQNS)=CONS(EQN,NIL); 942 BREAK } 943 EQNS=TL(EQNS); 944 } REPEAT 945 } 946 OR { LIST EQNS = TL(VAL(SUBJECT)); //NUMBERED EQN 947 WORD N = 0; 948 IF EQNO % 100!=0 || EQNO==0 //IF EQN HAS NON STANDARD LINENO 949 DO TL(EQN)=CONS((LIST)LINENO_C,CONS((LIST)EQNO,TL(EQN))); //MARK WITH NO. 950 do{N=HD(TL(HD(EQNS)))==(LIST)LINENO_C ? (WORD)HD(TL(TL(HD(EQNS)))) : 951 (N/100+1)*100; 952 IF EQNO==N 953 DO { HD(EQNS)=EQN; 954 CLEARMEMORY(); 955 BREAK } 956 IF EQNO<N 957 DO { LIST HOLD=HD(EQNS); 958 HD(EQNS)=EQN; 959 TL(EQNS)=CONS(HOLD,TL(EQNS)); 960 CLEARMEMORY(); 961 BREAK } 962 IF TL(EQNS)==NIL 963 DO { TL(EQNS)=CONS(EQN,NIL); 964 BREAK } 965 EQNS=TL(EQNS); 966 } REPEAT 967 } 968 SAVED=FALSE; 969 } } } 970 971 STATIC VOID 972 CLEARMEMORY() //CALLED WHENEVER EQNS ARE DESTROYED,REORDERED OR 973 //INSERTED (OTHER THAN AT THE END OF A DEFINITION) 974 { UNTIL MEMORIES==NIL //MEMORIES HOLDS A LIST OF ALL VARS WHOSE MEMO 975 DO { LIST X=VAL((ATOM)HD(MEMORIES)); //FIELDS HAVE BEEN SET 976 UNLESS X==NIL DO HD(HD(TL(X)))=0; //UNSET MEMO FIELD 977 MEMORIES=TL(MEMORIES); } } 978 979 VOID 980 ENTERSCRIPT(ATOM A) //ENTERS "A" IN THE SCRIPT 981 { TEST SCRIPT==NIL 982 THEN SCRIPT=CONS((LIST)A,NIL); 983 OR { LIST S=SCRIPT; 984 UNTIL TL(S)==NIL 985 DO S=TL(S); 986 TL(S) = CONS((LIST)A,NIL); } 987 } 988 989 STATIC VOID 990 COMMENT() 991 { ATOM SUBJECT=(ATOM)TL(HD(TOKENS)); 992 LIST COMMENT=HD(TL(TOKENS)); 993 IF VAL(SUBJECT)==NIL 994 DO { VAL(SUBJECT)=CONS(CONS(0,NIL),NIL); 995 ENTERSCRIPT(SUBJECT); } 996 IF PROTECTED(SUBJECT) DO RETURN 997 TL(HD(VAL(SUBJECT)))=COMMENT; 998 IF COMMENT==NIL && TL(VAL(SUBJECT))==NIL 999 DO REMOVE(SUBJECT); 1000 SAVED=FALSE; 1001 } 1002 1003 STATIC VOID 1004 EVALUATION() 1005 { LIST CODE=EXP(); 1006 WORD CH=(WORD)HD(TOKENS); 1007 LIST E=0; //STATIC SO INVISIBLE TO GARBAGE COLLECTOR 1008 UNLESS HAVE((TOKEN)'!') DO CHECK((TOKEN)'?'); 1009 IF ERRORFLAG DO RETURN; 1010 CHECK(EOL); 1011 IF ATOBJECT DO { PRINTOB(CODE) ; NEWLINE(); } 1012 E=BUILDEXP(CODE); 1013 IF ATCOUNT DO RESETGCSTATS(); 1014 INITSTATS(); 1015 EVALUATING=TRUE; 1016 FORMATTING=CH=='?'; 1017 PRINTVAL(E,FORMATTING); 1018 IF FORMATTING DO NEWLINE(); 1019 CLOSECHANNELS(); 1020 EVALUATING=FALSE; 1021 IF ATCOUNT DO OUTSTATS(); 1022 } 1023 1024 STATIC VOID 1025 ABORDERCOM() 1026 { SCRIPT=SORT(SCRIPT),SAVED=FALSE; } 1027 1028 STATIC LIST 1029 SORT(LIST X) 1030 { IF X==NIL || TL(X)==NIL DO RESULTIS X; 1031 { LIST A=NIL, B=NIL, HOLD=NIL; //FIRST SPLIT X 1032 UNTIL X==NIL DO HOLD=A, A=CONS(HD(X),B), B=HOLD, X=TL(X); 1033 A=SORT(A),B=SORT(B); 1034 UNTIL A==NIL||B==NIL //NOW MERGE THE TWO HALVES BACK TOGETHER 1035 DO TEST ALFA_LS((ATOM)HD(A),(ATOM)HD(B)) 1036 THEN X=CONS(HD(A),X), A=TL(A); 1037 OR X=CONS(HD(B),X), B=TL(B); 1038 IF A==NIL DO A=B; 1039 UNTIL A==NIL DO X=CONS(HD(A),X), A=TL(A); 1040 RESULTIS REVERSE(X); } 1041 } 1042 1043 STATIC VOID 1044 REORDERCOM() 1045 { TEST ISID(HD(TOKENS)) && (ISID(HD(TL(TOKENS))) || HD(TL(TOKENS))==(LIST)DOTDOT_SY) 1046 THEN SCRIPTREORDER(); OR 1047 TEST HAVEID() && HD(TOKENS)!=EOL 1048 THEN { LIST NOS = NIL; 1049 WORD MAX = NO_OF_EQNS(THE_ID); 1050 WHILE HAVENUM() 1051 DO { WORD A=THE_NUM; 1052 WORD B = HAVE(DOTDOT_SY) ? 1053 HAVENUM()? THE_NUM : MAX : A; 1054 WORD I; 1055 FOR (I=A; I<=B; I++) 1056 IF !MEMBER(NOS,(LIST)I) && 1<=I && I<=MAX 1057 DO NOS=CONS((LIST)I,NOS); 1058 //NOS OUT OF RANGE ARE SILENTLY IGNORED 1059 } 1060 CHECK(EOL); 1061 IF ERRORFLAG DO RETURN 1062 IF VAL(THE_ID)==NIL 1063 DO { DISPLAY(THE_ID,FALSE,FALSE); 1064 RETURN } 1065 IF PROTECTED(THE_ID) DO RETURN 1066 { WORD I; 1067 FOR (I=1; I<= MAX; I++) 1068 UNLESS MEMBER(NOS,(LIST)I) 1069 DO NOS=CONS((LIST)I,NOS); 1070 // ANY EQNS LEFT OUT ARE TACKED ON AT THE END 1071 } 1072 // NOTE THAT "NOS" ARE IN REVERSE ORDER 1073 { LIST NEW = NIL; 1074 LIST EQNS = TL(VAL(THE_ID)); 1075 UNTIL NOS==NIL 1076 DO { LIST EQN=ELEM(EQNS,(WORD)HD(NOS)); 1077 REMOVELINENO(EQN); 1078 NEW=CONS(EQN,NEW); 1079 NOS=TL(NOS); } 1080 // NOTE THAT THE EQNS IN "NEW" ARE NOW IN THE CORRECT ORDER 1081 TL(VAL(THE_ID))=NEW; 1082 DISPLAY(THE_ID,TRUE,FALSE); 1083 SAVED=FALSE; 1084 CLEARMEMORY(); 1085 } } 1086 OR SYNTAX(); 1087 } 1088 1089 STATIC VOID 1090 SCRIPTREORDER() 1091 { LIST R=NIL; 1092 WHILE HAVEID() 1093 DO TEST HAVE(DOTDOT_SY) 1094 THEN { ATOM A=THE_ID, B=0; LIST X=NIL; 1095 TEST HAVEID() THEN B=THE_ID; OR 1096 IF HD(TOKENS)==EOL DO B=(ATOM)EOL; 1097 TEST B==0 THEN SYNTAX(); OR X=EXTRACT(A,B); 1098 IF X==NIL DO SYNTAX(); 1099 R=SHUNT(X,R); } 1100 OR TEST MEMBER(SCRIPT,(LIST)THE_ID) 1101 THEN R=CONS((LIST)THE_ID,R); 1102 OR { WRITEF("\"%s\" not in script\n",PRINTNAME(THE_ID)); 1103 SYNTAX(); } 1104 CHECK(EOL); 1105 IF ERRORFLAG DO RETURN 1106 { LIST R1 = NIL; 1107 UNTIL TL(R)==NIL 1108 DO { UNLESS MEMBER(TL(R),HD(R)) DO SCRIPT=SUB1(SCRIPT,(ATOM)HD(R)), R1=CONS(HD(R),R1); 1109 R=TL(R); } 1110 SCRIPT=APPEND(EXTRACT((ATOM)HD(SCRIPT),(ATOM)HD(R)),APPEND(R1,TL(EXTRACT((ATOM)HD(R),(ATOM)EOL)))); 1111 SAVED=FALSE; 1112 } } 1113 1114 STATIC WORD 1115 NO_OF_EQNS(ATOM A) 1116 { RESULTIS VAL(A)==NIL ? 0 : LENGTH(TL(VAL(A))); } 1117 1118 STATIC BOOL 1119 PROTECTED(ATOM A) 1120 //LIBRARY FUNCTIONS ARE RECOGNISABLE BY NOT BEING PART OF THE SCRIPT 1121 { IF MEMBER(SCRIPT,(LIST)A) DO RESULTIS FALSE; 1122 IF MEMBER(HOLDSCRIPT,(LIST)A) 1123 DO { UNLESS MEMBER(GET_HITS,(LIST)A) DO GET_HITS=CONS((LIST)A,GET_HITS); 1124 RESULTIS FALSE; } 1125 WRITEF("\"%s\" is predefined and cannot be altered\n",PRINTNAME(A)); 1126 RESULTIS TRUE; } 1127 1128 STATIC VOID 1129 REMOVE(ATOM A) // REMOVES "A" FROM THE SCRIPT 1130 { SCRIPT=SUB1(SCRIPT,A); 1131 VAL(A)=NIL; 1132 } 1133 1134 STATIC LIST 1135 EXTRACT(ATOM A, ATOM B) //RETURNS A SEGMENT OF THE SCRIPT 1136 { LIST S=SCRIPT, X=NIL; 1137 UNTIL S==NIL || HD(S)==(LIST)A DO S=TL(S); 1138 UNTIL S==NIL || HD(S)==(LIST)B DO X=CONS(HD(S),X),S=TL(S); 1139 UNLESS S==NIL DO X=CONS(HD(S),X); 1140 IF S==NIL && B!=(ATOM)EOL DO X=NIL; 1141 IF X==NIL DO WRITEF("\"%s..%s\" not in script\n", 1142 PRINTNAME(A),B==(ATOM)EOL?"":PRINTNAME(B)); 1143 RESULTIS REVERSE(X); } 1144 1145 STATIC VOID 1146 DELETECOM() 1147 { LIST DLIST = NIL; 1148 WHILE HAVEID() 1149 DO TEST HAVE(DOTDOT_SY) 1150 THEN { ATOM A=THE_ID, B=(ATOM)EOL; 1151 TEST HAVEID() 1152 THEN B=THE_ID; OR 1153 UNLESS HD(TOKENS)==EOL DO SYNTAX(); 1154 DLIST=CONS(CONS((LIST)A,(LIST)B),DLIST); } OR 1155 { WORD MAX = NO_OF_EQNS(THE_ID); 1156 LIST NLIST = NIL; 1157 WHILE HAVENUM() 1158 DO { WORD A = THE_NUM; 1159 WORD B = HAVE(DOTDOT_SY) ? 1160 HAVENUM()?THE_NUM:MAX : A; 1161 WORD I; 1162 FOR (I=A; I<=B; I++) 1163 NLIST=CONS((LIST)I,NLIST); 1164 } 1165 DLIST=CONS(CONS((LIST)THE_ID,NLIST),DLIST); 1166 } 1167 CHECK(EOL); 1168 IF ERRORFLAG DO RETURN 1169 { WORD DELS = 0; 1170 IF DLIST==NIL //DELETE ALL 1171 DO { 1172 TEST SCRIPT==NIL THEN DISPLAYALL(FALSE); OR 1173 { UNLESS MAKESURE() DO RETURN 1174 UNTIL SCRIPT==NIL 1175 DO { DELS=DELS + NO_OF_EQNS((ATOM)HD(SCRIPT)); 1176 VAL((ATOM)HD(SCRIPT))=NIL; 1177 SCRIPT=TL(SCRIPT); } } } 1178 UNTIL DLIST == NIL 1179 DO TEST ISATOM(TL(HD(DLIST))) || TL(HD(DLIST))==EOL //"NAME..NAME" 1180 THEN { LIST X=EXTRACT((ATOM)HD(HD(DLIST)),(ATOM)TL(HD(DLIST))); 1181 DLIST=TL(DLIST); 1182 UNTIL X==NIL 1183 DO DLIST=CONS(CONS(HD(X),NIL),DLIST), X=TL(X); } OR 1184 { ATOM NAME = (ATOM)HD(HD(DLIST)); 1185 LIST NOS = TL(HD(DLIST)); 1186 LIST NEW = NIL; 1187 DLIST=TL(DLIST); 1188 IF VAL(NAME) == NIL 1189 DO { DISPLAY(NAME,FALSE,FALSE); 1190 LOOP } 1191 IF PROTECTED(NAME) DO LOOP 1192 TEST NOS==NIL 1193 THEN { DELS=DELS+NO_OF_EQNS(NAME); 1194 REMOVE(NAME); 1195 LOOP } 1196 OR { 1197 WORD I; 1198 FOR (I=NO_OF_EQNS(NAME); I>=1; I=I-1) 1199 TEST MEMBER(NOS,(LIST)I) 1200 THEN DELS=DELS+1; 1201 OR { LIST EQN=ELEM(TL(VAL(NAME)),I); 1202 REMOVELINENO(EQN); 1203 NEW=CONS(EQN,NEW); } } 1204 TL(VAL(NAME))=NEW; 1205 IF NEW==NIL && 1206 TL(HD(VAL(NAME)))==NIL //COMMENT FIELD 1207 DO REMOVE(NAME); } 1208 WRITEF("%" W " equations deleted\n",DELS); 1209 IF DELS>0 DO { SAVED=FALSE; CLEARMEMORY(); } 1210 } }