From 40e5a5811c6ffce9b0974e93cdd927cbcf60c157 Mon Sep 17 00:00:00 2001 From: Joe Hunkeler Date: Tue, 11 Aug 2015 16:51:37 -0400 Subject: Repatch (from linux) of OSX IRAF --- pkg/cl/main.c | 716 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 716 insertions(+) create mode 100644 pkg/cl/main.c (limited to 'pkg/cl/main.c') diff --git a/pkg/cl/main.c b/pkg/cl/main.c new file mode 100644 index 00000000..0471f4c7 --- /dev/null +++ b/pkg/cl/main.c @@ -0,0 +1,716 @@ +/* Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + */ + +#define import_spp +#define import_libc +#define import_fset +#define import_main +#define import_stdio +#define import_error +#define import_setjmp +#define import_knames +#define import_prtype +#define import_xwhen +#define import_xnames +#include + +#include +#include "config.h" +#include "grammar.h" +#include "opcodes.h" +#include "operand.h" +#include "param.h" +#include "clmodes.h" +#include "task.h" +#include "errs.h" +#include "mem.h" +#include "proto.h" + + +#define CLDIR "cl$" +#define HOSTLIB "hlib$" + +/* + * MAIN -- The main program of the CL. + * + * Repetitively call yyparse() and run() until hit eof (or "bye") during + * the lowest cl. The instructions exec and bye change the pc so that + * new code is compiled and run in a recursive fashion without having to + * call run() itself recursively. + * + * TODO: + * check access rights of file-type params in inspect. + * add < and > chars to mode param. + * all the other TODO's and more i'm sure... + */ + +#define FOREGROUND 0 +#define BACKGROUND 1 +#define BKG_QUANTUM 30 /* period(sec) bkgjob checkup */ +#define MAX_INTERRUPTS 5 /* max interrupts of a task */ +#define LEN_INTRSTK 10 /* max nesting of saved interrupts */ +typedef int (*PFI)(); + +extern int yydebug; /* print each parser state if set */ +extern FILE *yyin; /* where parser reads from */ +extern int yeof; /* set when yacc sees eof */ +extern int dobkg; /* set when code is to be done in bkg */ +extern int bkgno; /* job number if bkg job */ + +int cldebug = 0; /* print out lots of goodies if > 0 */ +int cltrace = 0; /* trace instruction execution if > 0 */ + +static PFI old_onipc; /* X_IPC handler chained to onint() */ +static long *jumpcom; /* IRAF Main setjmp/longjmp buffer */ +static jmp_buf jmp_save; /* save IRAF Main jump vector */ +static jmp_buf jmp_clexit; /* clexit() jumps here */ +static int intr_sp; /* interrupt save stack pointer */ +static XINT intr_save[LEN_INTRSTK]; /* the interrupt save stack */ +memel cl_dictbuf[DICTSIZE]; /* the dictionary area */ + +jmp_buf errenv; /* cl_error() jumps here */ +jmp_buf intenv; /* X_INT during process jumps here */ +int validerrenv; /* stays 0 until errenv gets set */ +int loggingout; /* set while processing logout file */ +int gologout; /* set when logout() is typed */ +int alldone; /* set by oneof when popping firstask */ +int recursion; /* detect error recursion in ONERROR */ +int errlev; /* detect error recursion in CL_ERROR */ +int ninterrupts; /* number of onint() calls per task */ +long cpustart, clkstart; /* starting cpu, clock times if bkg */ +int logout_status = 0; /* optional status arg to logout() */ + + +static void execute(); +static void login(), logout(); +static void startup(), shutdown(); + +extern void ZDOJMP(); +extern void c_xwhen(), onint(); +extern int yyparse(); + + +/* C_MAIN -- Called by the SPP procedure in cl.x to fire up the CL. + * In effect we are chained to the IRAF Main, being called immediately after + * the file system, etc. is initialized. When we exit we signal that the + * interpreter be skipped, proceeding directly to process shutdown. + */ +int +c_main ( + int *prtype, /* process type (connected, detached) */ + PKCHAR *bkgfile, /* bkgfile filename if detached */ + PKCHAR *cmd /* host command line */ +) +{ + XINT bp; + + /* Save the setjmp vector of the IRAF Main for restoration at clexit + * time. We need to intercept all errors and do error recovery + * ourselves during normal execution, but when the CL exits we are + * not prepared to deal with errors occuring during shutdown. + */ + XMJBUF (&bp); jumpcom = (long *)&Memc[bp]; + cl_amovi ((int *)jumpcom, (int *)jmp_save, LEN_JUMPBUF); + + /* Init clexit() in case we have to panic stop. */ + if (setjmp (jmp_clexit)) + goto exit_; + + /* Set up dictionary and catch signals. If we are background, read in + * file and jump right into run, else hand craft first task. Die if + * these fail. + */ + startup (); + + if (*prtype == PR_DETACHED) { + bkg_startup ((char *)bkgfile); + cpustart = c_cputime (0L); + clkstart = c_clktime (0L); + execute (BACKGROUND); + } else { + login ((char *) cmd); + execute (FOREGROUND); + logout(); + execute (FOREGROUND); + } + + shutdown(); + +exit_: + /* Return to the IRAF Main. The PR_EXIT code commands the main to + * skip the interpreter loop and shutdown. Restore the error + * jump vector in the IRAF Main so that it can handle errors occuring + * during shutdown; we are turning control back over to the Main. + * This is ugly, but the real problem is the jump vectors. There + * seems to be no alternative to this sort of thing... + */ + cl_amovi ((int *)jmp_save, (int *)jumpcom, LEN_JUMPBUF); + return (PR_EXIT | (logout_status << 1)); +} + + +/* CLEXIT -- Called on fatal error from error() when get an error so bad that we + * should commit suicide. + */ +void +clexit (void) +{ + longjmp (jmp_clexit, 1); +} + + +/* CLSHUTDOWN -- Public entry for shutdown. + */ +void +clshutdown (void) +{ + shutdown(); +} + + +/* STARTUP -- CL startup code. Called by onentry() at process startup. + * Allocate space for the dictionary, post exception handlers, initialize + * error recovery. + * + * NOTE: in the current implementation a fixed size buffer is allocated for + * the dictionary due to the difficulty of passing the dictionary to the + * bkg CL if a dynamically allocated dictionary is used. The problem is + * that the dictionary is full of pointers to absolute addresses, and + * we cannot control where the memory allocator in the bkg CL will allocate + * a buffer. A simple binary copy of the dictionary to different region + * of memory in the bkg CL will leave the pointers pointing into limbo. + * + * TODO: Write a pair of procedures for each major data structure to dump + * and restore the data structure in a binary array. Passing the CL context + * to the bkg CL would then be a matter of calling the dump procedure for + * each major data structure to dump the structure into the bkgfile, then + * doing a matching restore in the bkg CL to restore the data structure + * to a different region of memory. The ENV package does this already. + * The only alternative would be to use indices rather than pointers in + * the dictionary, which is not what C likes to do. + */ +static void +startup (void) +{ + void onint(), onipc(), c_xwhen(); + + /* Set up pointers to dictionary buffer. + */ + dictionary = cl_dictbuf; + topd = 0; + maxd = DICTSIZE; + + if (cldebug) + printf ("dictionary starts at %d (0%o)\n", dictionary, dictionary); + + /* Post exception handlers for interrupt and write to IPC with no + * reader. The remaining exceptions use the standard handler. + */ + c_xwhen (X_IPC, onipc, &old_onipc); + intr_reset(); + + /* The following is a temporary solution to an initialization problem + * with pseudofile i/o. + */ + PRPSINIT(); +} + + +/* SHUTDOWN -- Call this to exit gracefully from the whole cl; never return. + * Write out any remaining PF_UPDATE'd pfiles by restoring topd to just above + * first task unless we are in batch mode, then just flush io and die.. + * So that the restor will include the cl's pfile and any other pfiles that + * might have been cached or assigned into, we force its topd to be + * below its pfile head. See the "pfp < topdp" loop in restor(). + * Don't bother with restor'ing if BATCH since we don't want to write out + * anything then anyway. + */ +static void +shutdown (void) +{ + float cpu, clk; + + pr_dumpcache (0, YES); /* flush process cache */ + clgflush(); /* flush graphics output */ + + if (firstask->t_flags & T_BATCH) { + iofinish (currentask); + if (notify()) { + cpu = (float)c_cputime(cpustart) / 1000.; + clk = (float)c_clktime(clkstart); + fprintf (stderr, "\n[%d] done %.1f %.0m %d%%\n", bkgno, + cpu, clk/60., (int)((clk > 0 ? cpu / clk : 0.) * 100.)); + } + } else { + firstask->t_topd = dereference (firstask->t_ltp) + LTASKSIZ; + restor (firstask); + } + + yy_startblock (LOG); /* flush and close log */ + close_logfile (logfile()); + clexit(); +} + + +/* EXECUTE -- Each loop corresponds to an exec in the interpreted code. + * This occurs when a script task or process is ready to run. In background + * mode, we skip the preliminaries and jump right in and interpret the + * compiled code. + */ +static void +execute (int mode) +{ + int parsestat; + XINT old_parhead; + char *curcmd(); + + alldone = 0; + gologout = 0; + if (mode == BACKGROUND) { + if (setjmp (jumpcom)) + onerr(); + goto bkg; + } + + /* Called when control stack contains only the firsttask. ONEOF sets + * alldone true when eof/bye is seen and currentask=firstask, + * terminating the loop and returning to main. + */ + do { + /* Bkg_update() checks for blocked or finished bkg jobs and prints + * a message if it finds one. This involves one or more access() + * calls so don't call it more than every 5 seconds. The errenv + * jump vector is used by cl_error() for error restart. The JUMPCOM + * vector is used to intercept system errors which would otherwise + * restart the CL. + */ + if (currentask->t_flags & T_INTERACTIVE) { + static long last_clktime; + + if (c_clktime (last_clktime) > BKG_QUANTUM) { + last_clktime = c_clktime (0L); + bkg_update (1); + } + validerrenv = 1; + setjmp (errenv); + ninterrupts = 0; + if (setjmp (jumpcom)) + onerr(); + } else if (!(currentask->t_flags & T_SCRIPT)) + setjmp (intenv); + + pc = currentask->t_bascode; + currentask->t_topd = topd; + currentask->t_topcs = topcs; + recursion = 0; + errlev = 0; + c_erract (OK); + yeof = 0; + + /* In the new CL the parser needs to know more about parameters + * than before. Hence param files may be read in during parsing. + * Since we discard the dictionary after parsing we must unlink + * these param files, and re-read them when the + * program is run. This is inefficient but appears to work. + */ + old_parhead = parhead; + + if (gologout) + yeof++; + else { + yy_startblock (LOG); /* start new history blk */ + parsestat = yyparse(); /* parse command block */ + topd = currentask->t_topd; /* discard addconst()'s */ + topcs = currentask->t_topcs; /* discard compiler temps */ + parhead = old_parhead; /* forget param files. */ + if (parsestat != 0) + cl_error (E_IERR, "parser gagged"); + } + + if (dobkg) { + bkg_spawn (curcmd()); + } else { +bkg: + if (yeof) + oneof(); /* restores previous task */ + else { + /* set stack above pc, point pc back to code */ + topos = basos = pc - 1; + pc = currentask->t_bascode; + } + + if (!alldone) + run(); /* run code starting at pc */ + } + } until (alldone); +} + + +/* LOGIN -- Hand-craft the first cl process. Push the first task to become + * currentask, set up clpackage at pachead and set cl as its first ltask. + * Add the builtin function ltasks. Run the startup file as the stdin of cl. + * If any of this fails, we die. + */ +static void +login (char *cmd) +{ + register struct task *tp; + register char *ip, *op; + struct ltask *ltp; + struct operand o; + char *loginfile = LOGINFILE; + char alt_loginfile[SZ_PATHNAME]; + char clstartup[SZ_PATHNAME]; + char clprocess[SZ_PATHNAME]; + char *arglist; + + strcpy (clstartup, HOSTLIB); + strcat (clstartup, CLSTARTUP); + strcpy (clprocess, CLDIR); + strcat (clprocess, CLPROCESS); + + tp = firstask = currentask = pushtask(); + tp->t_in = tp->t_stdin = stdin; + tp->t_out = tp->t_stdout = stdout; + tp->t_stderr = stderr; + tp->t_stdgraph = fdopen (STDGRAPH, "w"); + tp->t_stdimage = fdopen (STDIMAGE, "w"); + tp->t_stdplot = fdopen (STDPLOT, "w"); + tp->t_pid = -1; + tp->t_flags |= (T_INTERACTIVE|T_CL); + + /* Make root package. Avoid use of newpac() since pointers are not + * yet set right. + */ + pachead = topd; + curpack = (struct package *) memneed (PACKAGESIZ); + curpack->pk_name = comdstr (ROOTPACKAGE); + curpack->pk_ltp = NULL; + curpack->pk_pfp = NULL; + curpack->pk_npk = NULL; + curpack->pk_flags = 0; + + /* Make first ltask. + */ + ltp = newltask (curpack, "cl", clprocess, (struct ltask *) NULL); + tp->t_ltp = ltp; + ltp->lt_flags |= (LT_PFILE|LT_CL); + + tp->t_pfp = pfileload (ltp); /* call newpfile(), read cl.par */ + tp->t_pfp->pf_npf = NULL; + setclmodes (tp); /* uses cl's params */ + + setbuiltins (curpack); /* add more ltasks off clpackage*/ + + /* Define the second package, the "clpackage", and make it the + * current package (default package at startup). Tasks subsequently + * defined by the startup script will get put in clpackage. + */ + curpack = newpac (CLPACKAGE, "bin$"); + + /* Compile code that will run the startup script then, if it exists + * in the current directory, a login.cl script. We need to do as + * much by hand here as the forever loop in main would have if this + * code came from calling yyparse(). + */ + if (c_access (clstartup,0,0) == NO) + cl_error (E_FERR, "Cannot find startup file `%s'", clstartup); + + currentask->t_bascode = 0; + pc = 0; + o.o_type = OT_STRING; + o.o_val.v_s = clstartup; + compile (CALL, "cl"); + compile (PUSHCONST, &o); + compile (REDIRIN); + compile (EXEC); + compile (FIXLANGUAGE); + + /* The following is to permit error recovery in the event that an + * error occurs while reading the user's LOGIN.CL file. + */ + validerrenv = 1; + if (setjmp (errenv)) { + eprintf ("Error while reading login.cl file"); + eprintf (" - may need to rebuild with mkiraf\n"); + eprintf ("Fatal startup error. CL dies.\n"); + clexit(); + } + ninterrupts = 0; + if (setjmp (jumpcom)) + onerr(); + + /* Nondestructively decompose the host command line into the startup + * filename and/or the argument string. + */ + if (strncmp (cmd, "-f", 2) == 0) { + for (ip=cmd+2; *ip && isspace(*ip); ip++) + ; + for (op=alt_loginfile; *ip && ! isspace(*ip); *op++ = *ip++) + ; + *op = EOS; + + for ( ; *ip && isspace(*ip); ip++) + ; + arglist = ip; + + } else { + *alt_loginfile = EOS; + arglist = cmd; + } + + /* Copy any user supplied host command line arguments into the + * CL parameter $args to use in the startup script (for instance). + */ + o.o_type = OT_STRING; + strcpy (o.o_val.v_s, arglist); + compile (PUSHCONST, &o); + compile (ASSIGN, "args"); + + if (alt_loginfile[0]) { + if (c_access (alt_loginfile,0,0) == NO) + printf ("Warning: script file %s not found\n", alt_loginfile); + else { + o.o_val.v_s = alt_loginfile; + compile (CALL, "cl"); + compile (PUSHCONST, &o); + compile (REDIRIN); + compile (EXEC); + } + + } else if (c_access (loginfile,0,0) == NO) { + char *home = envget ("HOME"); + char global[SZ_LINE]; + + memset (global, 0, SZ_LINE); + sprintf (global, "%s/.iraf/login.cl", home); + if (c_access (global, 0, 0) == YES) { + o.o_val.v_s = global; + compile (CALL, "cl"); + compile (PUSHCONST, &o); + compile (REDIRIN); + compile (EXEC); + } else { + printf ("Warning: no login.cl found in login directory\n"); + } + + } else { + o.o_val.v_s = loginfile; + compile (CALL, "cl"); + compile (PUSHCONST, &o); + compile (REDIRIN); + compile (EXEC); + } + + compile (END); + topos = basos = pc - 1; + pc = 0; + run(); /* returns after doing the first EXEC */ + + /* Add nothing here that will effect the dictionary or the stacks. + */ + if (cldebug) + printf ("topd, pachead, parhead: %u, %u, %u\n", + topd, pachead, parhead); +} + + +/* LOGOUT -- Process the system logout file. Called when the user logs + * off in an interactive CL (not called by bkg cl's). The standard input + * of the CL is hooked to the system logout file and when the eof of the + * logout file is seen the CL really does exit. + */ +static void +logout (void) +{ + register struct task *tp; + char logoutfile[SZ_PATHNAME]; + FILE *fp; + + strcpy(logoutfile, HOSTLIB); + strcat(logoutfile, CLLOGOUT); + + if ((fp = fopen (logoutfile, "r")) == NULL) + cl_error (E_FERR, + "Cannot open system logout file `%s'", logoutfile); + + tp = firstask; + tp->t_in = tp->t_stdin = fp; + yyin = fp; + tp->t_flags = (T_CL|T_SCRIPT); + loggingout = 1; + gologout = 0; +} + + +/* MEMNEED -- Increase topd by incr INT's. Since at present the dictionary + * is fixed in size, abort if the dictionary overflows. + */ +char * +memneed ( + int incr /* amount of space desired in ints, not bytes */ +) +{ + memel *old; + + old = daddr (topd); + topd += incr; + + /* Quad alignment is desirable for some architectures. */ + if (topd & 1) + topd++; + + if (topd > maxd) + cl_error (E_IERR, "dictionary full"); + + return ((char *)old); +} + + +/* ONINT -- Called when the interrupt exception occurs, i.e., the usual user + * attention-getter. (cntrl-c on dec, delete on unix, etc.). Also called + * when we are killed as a bkg job. + * If the current task is a script or the terminal, abort execution and + * initiate error recovery. If the task is in a child process merely send + * interrupt to the child and continue execution (giving the child a chance + * to cleanup before calling error, or to ignore the interrupt entirely). + * If the task wants to terminate it will send the ERROR statement to the CL. + * If we are a bkg job, call bkg_abort to clean up (delete temp files, etc.) + * before shutting down. + */ +/* ARGSUSED */ +void +onint ( + int *vex, /* virtual exception code */ + int (**next_handler)() /* next handler to be called */ +) +{ + if (firstask->t_flags & T_BATCH) { + /* Batch task. + */ + iofinish (currentask); + bkg_abort(); + clexit(); + + } else if (currentask->t_flags & (T_SCRIPT|T_CL|T_BUILTIN)) { + /* CL task. + */ + cl_error (E_UERR, "interrupt!!!"); + + } else { + /* External task connected via IPC. Pass the interrupt on to + * the child. + */ + c_prsignal (currentask->t_pid, X_INT); + + /* Cancel any output and disable i/o on the tasks pseudofiles. + * This is necessary to cancel any i/o still buffered in the + * IPC channel. Commonly when the task is writing to STDOUT, + * for example, the CL will be writing the last buffer sent + * to the terminal, while the task waits after having already + * pushed the next buffer into the IPC. When we resume reading + * from the task we will see this buffered output on the next + * read and we wish to discard it. Leave STDERR connected to + * give a path to the terminal for recovery actions such as + * turning standout or graphics mode off. This gives the task + * a chance to cleanup but does not permit full recovery. The + * pseudofiles will be reconnected for the next task run. + */ + c_fseti (fileno(stdout), F_CANCEL, OK); + c_fseti (fileno(currentask->t_in), F_CANCEL, OK); + c_fseti (fileno(currentask->t_out), F_CANCEL, OK); + + c_prredir (currentask->t_pid, STDIN, 0); + c_prredir (currentask->t_pid, STDOUT, 0); + + /* If a subprocess is repeatedly interrupted we assume that it + * is hung in a loop and abort, advising the user to kill the + * process. + */ + if (++ninterrupts >= MAX_INTERRUPTS) + cl_error (E_UERR, "subprocess is hung; should be killed"); + else + longjmp (intenv, 1); + } + + *next_handler = NULL; +} + + +/* INTR_DISABLE -- Disable interrupts, e.g., to protect a critical section + * of code. + */ +void +intr_disable (void) +{ + PFI junk; + + if (intr_sp >= LEN_INTRSTK) + cl_error (E_IERR, "interrupt save stack overflow"); + c_xwhen (X_INT, X_IGNORE, &junk); + intr_save[intr_sp++] = (XINT) junk; +} + + +/* INTR_ENABLE -- Reenable interrupts, reposting the interrupt vector saved + * in a prior call to INTR_DISABLE. + */ +void +intr_enable (void) +{ + PFI junk; + + if (--intr_sp < 0) + cl_error (E_IERR, "interrupt save stack underflow"); + c_xwhen (X_INT, intr_save[intr_sp], &junk); +} + + +/* INTR_RESET -- Post the interrupt handler and clear the interrupt vector + * save stack. + */ +void +intr_reset (void) +{ + PFI junk; + + c_xwhen (X_INT, onint, &junk); + intr_sp = 0; +} + + +/* ONERR -- Called when system error recovery takes place. The setjmp in + * execute() overrides the setjmp (ZSVJMP) in the IRAF Main. When system error + * recovery takes place, c_erract() calls ZDOJMP to restart the IRAF Main. + * We do not want to lose the runtime context of the CL, so we restart the + * CL main instead by intercepting the vector. We get the error message from + * the system and call cl_error() which eventually does a longjmp back to + * the errenv in execute(). + */ +void +onerr (void) +{ + char errmsg[SZ_LINE]; + + c_erract (EA_RESTART); + c_errget (errmsg, SZ_LINE); + + if (recursion++) + longjmp (errenv, 1); + else + cl_error (E_UERR, errmsg); +} + + +/* CL_AMOVI -- Copy an integer sized block of memory. + */ +void +cl_amovi ( + register int *ip, + register int *op, + register int len +) +{ + while (--len) + *op++ = *ip++; +} -- cgit