/* +-------+-----------------+------+-----------------+-------+-----------------+ |Program| EXEC_4TH.C |Header| 4TH.H |Library| 4TH | +-------+-----------------+------+-----------------+-------+----------+------+ |HISTORY | Programmer | Date | +--------------------------------------------------+------------------+------+ | Turbo C V2.0 version | J.L. Bezemer |181094| | DPX/2 340 version | J.L. Bezemer |181094| | Coherent V4.2 version | J.L. Bezemer |201094| | DJGPP V2.72 version | J.L. Bezemer |230597| | Linux 2.2.10 version | J.L. Bezemer |170600| +--------------------------------------------------+------------------+------+ |MODIFICATION LOG | Programmer | Date | +--------------------------------------------------+------------------+------+ | Added /MOD, * /, * /MOD, I', J, FAST, SLOW | J.L. Bezemer |191094| | Removed Flags, changed NOP to NOOP | J.L. Bezemer |191094| | Added M4UNKKEY message, .R, VARIABLE, V0@, USER@ | J.L. Bezemer |201094| | Added STACK@, LIMIT@, BASE@, SP@, RP@ | J.L. Bezemer |201094| | Added ABORT, EXIT, EXECUTE, TICK, C@, WAIT | J.L. Bezemer |241094| | Changed allocation of RStack, Stack, Vars | J.L. Bezemer |241094| | Added check on I/O, /. and /.R | J.L. Bezemer |271094| | Added randomizer, RANDOM and TIME | J.L. Bezemer |161194| | Optimized +LOOP a little; fixed LEAVE bug | J.L. Bezemer |140395| | Optimized +LOOP a little more | J.L. Bezemer |150395| | Fixed bug: ErrNo4th returns wrong errorcode | J.L. Bezemer |160395| | Changed , into C, and removed V0@ | J.L. Bezemer |180395| | Switched LIMIT@ and USER@ commands | J.L. Bezemer |180395| | Merged Stack and RStack | J.L. Bezemer |180395| | Fixed bug in ABORT | J.L. Bezemer |210395| | Rearranged commands to optimize performance | J.L. Bezemer |210395| | Changed LIMIT@ to VARS, USER@ to USER, C, to , | J.L. Bezemer |310395| | Changed STACK@ to STACK; added C, | J.L. Bezemer |310395| | Produced first interpreter of 4tH V2.0 | J.L. Bezemer |200495| | Redesigned allocation of variables | J.L. Bezemer |240495| | Removed STACK and VALUE | J.L. Bezemer |240495| | Reduced field in .R and /.R to max. 31 positions | J.L. Bezemer |250495| | Removed obsolete check reading in values | J.L. Bezemer |250495| | Made +LOOP Forth-compatible again | J.L. Bezemer |280495| | Removed INPUT, added string words | J.L. Bezemer |280495| | Added INRSET, changed PAD to FORMAT on some words| J.L. Bezemer |290495| | Increased field in .R and /.R to max. 63 pos. | J.L. Bezemer |300495| | Changed CONSTANT to LITERAL | J.L. Bezemer |300495| | Added #, #S, <#, #>, HOLD & SIGN; removed /., /.R| J.L. Bezemer |010595| | Changed ,@; added COPY | J.L. Bezemer |020595| | Added sharpS(), sign(), lsharp(), type(), dotR() | J.L. Bezemer |050995| | Removed dot(), changed emit(); removed BASEFCH | J.L. Bezemer |050995| | All I/O passes through emit(); added *Base | J.L. Bezemer |050995| | Made code more solid; added M4BADRDX messages | J.L. Bezemer |060995| | Fixed bug in dotR() and RSHARP code | J.L. Bezemer |060995| | Changed ,@ to '@; set radix limits correctly | J.L. Bezemer |060995| | Removed LEFT, RIGHT, !IN; added SHIFT and *In | J.L. Bezemer |110995| | Rewrote TEXT completely | J.L. Bezemer |120995| | Fixed tiny bugs: init >IN, loading extern vars | J.L. Bezemer |130995| | Added EXPECT command | J.L. Bezemer |140995| | Added expect(), FILE>, TTY>, DevIn | J.L. Bezemer |150995| | Added FILE* to expect(); QUERY reads from TTY | J.L. Bezemer |160995| | Added INFILE and OUTFILE | J.L. Bezemer |180995| | Fixed small bug in TEXT (incrementing >IN) | J.L. Bezemer |200995| | Updated errors | J.L. Bezemer |220995| | Changed EXPECT to ACCEPT, TEXT to WORD | J.L. Bezemer |080296| | Added LOOP; removed conditionals | J.L. Bezemer |080296| | Changed WORD, NUMBER and PRINT | J.L. Bezemer |080296| | Removed RETURN | J.L. Bezemer |090296| | Added cell support; changed COPY; added NE0 | J.L. Bezemer |100296| | Added Hcode support | J.L. Bezemer |120296| | Added HI and support for allocation | J.L. Bezemer |140296| | Added extra check to NUMBER | J.L. Bezemer |160296| | Added TO and VALUE | J.L. Bezemer |240296| | Changed NOT4 to INVERT | J.L. Bezemer |040396| | Removed LINE; changed VARS to LAST, USER to FIRST| J.L. Bezemer |050396| | Added return-value to pop() and removed argument | J.L. Bezemer |210496| | Cleaned up code and added comment | J.L. Bezemer |220496| | Changed store(), fetch(), sharp() | J.L. Bezemer |220496| | Added additional optimizations in pop() calls | J.L. Bezemer |220496| | Added some additional casts | J.L. Bezemer |230496| | Removed some casts | J.L. Bezemer |060596| | Rewrote to accomodate new Hcode format | J.L. Bezemer |021096| | Added RSP and SP | J.L. Bezemer |041096| | Renamed TICKFCH to FETCHPRM ('@ changed to @') | J.L. Bezemer |101096| | Moved RSP and SP to headerfile | J.L. Bezemer |201196| | Removed ABORT, added SP! and RP! | J.L. Bezemer |201196| | Replaced M4UNKTOK by M4BADOBJ; added F_F and F_T | J.L. Bezemer |031296| | Added CLOSEIO | J.L. Bezemer |061296| | Removed TTY>, >TTY, FILE>, >FILE, INFILE, OUTFILE| J.L. Bezemer |280297| | Added TTY, FILE, OPEN, CLOSE; removed CLOSEIO | J.L. Bezemer |280297| | Optimized TRAILING a little | J.L. Bezemer |150397| | Made In local, added RESULT variable | J.L. Bezemer |100497| | Added ) | J.L. Bezemer |110497| | Added throw(), THROW and HANDLER variable | J.L. Bezemer |170497| | Added PassThru to throw() | J.L. Bezemer |180497| | Added M4THROW | J.L. Bezemer |190497| | Optimized throw() a little | J.L. Bezemer |200497| | Changed return of rpop() on error | J.L. Bezemer |300497| | Changed return of pop() on error | J.L. Bezemer |040597| | Added LOCAL_H support; fixed GCC warning (Now) | J.L. Bezemer |220597| | Simplified PRINT and COPY; added toCharSeg() | J.L. Bezemer |240797| | Added ARGN and ARGS | J.L. Bezemer |240797| | Fixed small bug in ARGS; cleaned up COPY | J.L. Bezemer |250797| | Removed ; fixed serious bug in throw() | J.L. Bezemer |250797| | Removed some redundant Applet->ErrNo | J.L. Bezemer |260797| | Fixed GCC warning (setjmp); fixed small bug | J.L. Bezemer |270797| | Changed throw(), pop() and rpop() | J.L. Bezemer |300797| | Added BRANCHXT; changed header fieldname | J.L. Bezemer |120997| | Removed BRANCHXT; replaced some variables | J.L. Bezemer |170997| | Removed RCOPY2 and SHOW | J.L. Bezemer |260997| | Added unit to make Character Segment unsigned | J.L. Bezemer |270997| | Removed INC2 and DEC2; added QDO | J.L. Bezemer |151097| | Removed QUERY, added REFILL | J.L. Bezemer |311097| | Fixed DJGPP I/O error in accept() when EOT | J.L. Bezemer |061197| | Added CATCH and CAUGHT, changed Throw() | J.L. Bezemer |191197| | Changed RANDOM to use RNDMASK | J.L. Bezemer |221197| | Removed EasyC syntax | J.L. Bezemer |150198| | Changed fileIO() for new file attributes | J.L. Bezemer |160298| | Updated version info | J.L. Bezemer |180298| | Restored fileIO() and redesigned FOPEN code | J.L. Bezemer |200298| | Added SQUOTE | J.L. Bezemer |200298| | Integrated Web4tH variant | J.L. Bezemer |290999| | Removed unit datatype | J.L. Bezemer |301099| | Fixed error in accept() for GCC (flushing) | J.L. Bezemer |200600| | Restored accept(); REFILL works again | J.L. Bezemer |200600| | Removed WORD; added TOKEN and SKIP | J.L. Bezemer |160201| | Fixed small bug in FCLOSE; redirect to tty | J.L. Bezemer |240401| | Removed fileIO(); added OpenDevice, CloseDevice()| J.L. Bezemer |230202| | Fixed small bug in CloseDevice(), forced fclose()| J.L. Bezemer |230202| | Cleaned up pipe support for non-Unix platforms | J.L. Bezemer |240202| | Pipes on non-Unix platforms always fail | J.L. Bezemer |240202| | Added USE, removed TTY and FILE | J.L. Bezemer |280202| | Removed OpenDevice(), CloseDevice() | J.L. Bezemer |280202| | Added OpenStream(), CloseStream() | J.L. Bezemer |280202| | Changed emit(), accept() | J.L. Bezemer |280202| | Added NOPIPES directive; pipes are buggy | J.L. Bezemer |070302| | Added fix for pipes; Popen() and Pclose() | J.L. Bezemer |080302| | Fixed EOF bug in accept() | J.L. Bezemer |090302| | Restricted to TurboC to accomodate LCCW32| J.L. Bezemer |060502| | Added static modifier to Popen() and Pclose() | J.L. Bezemer |170902| | Changed ARGS, NUMBER, CMOVE, FOPEN | J.L. Bezemer |060603| | Removed COPY, NOOP, TOKEN, FETCHPRM, GE, LE | J.L. Bezemer |060603| | Added PARSE, OFETCH, STRINGD, CELLD, PLACE | J.L. Bezemer |060603| | Removed toCharSeg(); added cmove(), toPAD() | J.L. Bezemer |060603| | Added toCstring() | J.L. Bezemer |060603| | Changed SKIP to OMIT | J.L. Bezemer |120603| | Changed RESULT to OUT (Wil Baden) | J.L. Bezemer |020703| | Changed F4_UPDAT to F4_APPND; moved RPUT, RGET | J.L. Bezemer |070803| | Redesigned cmove(); added Win32 pipes support | J.L. Bezemer |291003| | Reshuffled init code in preparation of SLEEP | J.L. Bezemer |311003| | Added SLEEP | J.L. Bezemer |031103| | Fixed another 'clobbered' GCC warning | J.L. Bezemer |041103| | Updated documentation header, fixed TurboC warns | J.L. Bezemer |061103| | Made dormant VM slightly more robust; deleted Out| J.L. Bezemer |111103| | Changed USE; error instead of ignore on NULL dev.| J.L. Bezemer |131103| | Fixed a count bug in cmove() | J.L. Bezemer |211103| | Added VECTOR | J.L. Bezemer |011203| | Fixed small bugs in type() and -TRAILING | J.L. Bezemer |040104| | Added Object->Offset support | J.L. Bezemer |050104| | Removed WAIT | J.L. Bezemer |140104| | Added hidden variables, SaveStackFrame() | J.L. Bezemer |120304| | Added support for SOURCE and SOURCE! | J.L. Bezemer |151004| | Fixed small bug in FILL | J.L. Bezemer |191104| | Changed OFETCH to FETCHC | J.L. Bezemer |040305| | Rewrote the entire interpreter; fixed some bugs | J.L. Bezemer |050405| | Added XT() macro, changed JUMP(), DDROP() macros | J.L. Bezemer |060405| | Changed DO, RDROP() macro; fixed GCC 3.x warns | J.L. Bezemer |070405| | Fixed GCC 3.x error in SQUOTE and ARGS | J.L. Bezemer |170505| | Fixed DSIZE() error in MOD, changed FETCHC | J.L. Bezemer |230505| | Fixed potential bugs in CATCH | J.L. Bezemer |240505| | Removed superfluous check in PopStackFrame() | J.L. Bezemer |290505| | Added comparison in throw() | J.L. Bezemer |310505| | Changed OpenStream() and CloseStream() | J.L. Bezemer |101105| | Changed OPEN, CLOSE, CR and USE | J.L. Bezemer |101105| | Changed accept() and emit() | J.L. Bezemer |211105| | Removed CLSPAREN, HI, FIRST and LAST | J.L. Bezemer |110106| | Added ENVIRON and UseStream() | J.L. Bezemer |110106| | Added PLITERAL | J.L. Bezemer |130106| | Added UVAR(); changed STORE and ADDSTORE | J.L. Bezemer |160106| | Added DEV(), FSEEK and FTELL | J.L. Bezemer |180106| | Added UDEV(), SDEV() and ODEV() | J.L. Bezemer |190106| | Removed UseStream(); cleaned up I/O | J.L. Bezemer |190106| | Cleaned up FSEEK and FTELL a little | J.L. Bezemer |230106| | Fixed TurboC warning in PopStackFrame() | J.L. Bezemer |160206| | Changed CloseStream(); change channel if current | J.L. Bezemer |160306| | Changed accept(); all comparisons now VCIN, VCOUT| J.L. Bezemer |160306| | Fixed Unix pipe bug in OpenStream() | J.L. Bezemer |181106| | Fixed NOPIPES pipe bug in OpenStream() | J.L. Bezemer |201106| | Added CODE() and NEXT macros | J.L. Bezemer |040107| | Removed STSLHMOD; added SYNC | J.L. Bezemer |030507| | Added RADIX, OFFSET; removed HEX, DECIMAL, OCTAL | J.L. Bezemer |201207| | Changed accept() to Accept() on request | J.L. Bezemer |100708| | Changed OpenStream(); return CELL_MIN on error | J.L. Bezemer |061108| | Fixed tiny bug in OpenStream() | J.L. Bezemer |111108| | Moved emit() and Accept() to top | J.L. Bezemer |060209| +--------------------------------------------------+------------------+------+ |REMARKS | Programmer | Date | +--------------------------------------------------+------------------+------+ | None | | | +--------------------------------------------------+------------------+------+ Copyright (C) 1994,2009 J.L. Bezemer This file is part of 4tH 4tH is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. This program executes a 4tH program. The user variables can be preloaded and used inside a 4th program. VarN is assigned to the number of variables that are preloaded. ArgN is equivalent to argc; ArgS is equivalent to argv. This interface allows you to pass arguments and strings to a 4tH program. It returns the contents of variable OUT on success or CELL_MIN on error. Prototype: cell exec_4th (Hcode *Object, unsigned ArgN, char **ArgS, unsigned VarN, ...) Returns : cell, the contents of OUT on succes or CELL_MIN on error Memory : the size of the stack and variables and the user area Example : #include "4th.h" #include #include #ifndef ARCHAIC int main (int argc, char **argv) #else int main (argc, argv) int argc; char **argv; #endif { Hcode *object; char *sources; cell result; if (argc >= 2) { if ((sources = open_4th (argv [1])) == NULL) printf ("Loading; \'%s\' does not exist or too large\n", argv [1]); else { object = comp_4th (sources); if (object) { result = exec_4th (object, argc - 1, argv + 1, 2, 125L, 6L); printf ("Execute; word %u: %s\n", object->ErrLine, errs_4th [object->ErrNo]); printf ("\nResult of script: %ld\n", result); return (EXIT_SUCCESS); } } } return (EXIT_FAILURE); } Input : None Output : depends on program Related : dump_4th(), comp_4th() */ #ifdef USRLIB4TH #include #include <4th.h> #else #include "4th.h" #include "cmds_4th.h" #endif #include #include #include #include #include #include #ifdef UNIX #include #endif #ifdef __TURBOC__ #include #else #include #include #endif #define EOTu 4 /* Unix end of text character */ #define EOTm 26 /* Microsoft end of text character */ #define EXCEPTION 1 /* label for longjmp() */ #define OPERAND Object->CodeSeg[Object->ErrLine].Value #define PROGCOUNT Object->ErrLine #define SEED ((unsigned)(time(&Now)%37L)) /* randomizer seed */ #define CIN ((int)STD4IN) /* input device number */ #define COUT ((int)STD4OUT) /* output device number */ /* stack commands */ #define DFREE(a) if((ToRS-ToS)<(a))throw(M4SOVFLW) #define RFREE(a) if((ToRS-ToS)<(a))throw(M4ROVFLW) #define DSIZE(a) if(ToS<(a))throw(M4SEMPTY) #define RSIZE(a) if(ToRS>(R0-(a)))throw(M4REMPTY) #define DPOP (Stack[--ToS]) #define DPUSH(a) (Stack[ToS++]=(a)) #define RPOP (Stack[++ToRS]) #define RPUSH(a) (Stack[ToRS--]=(a)) #define DDROP ToS-- #define RDROP ToRS++ #define RS(a) (Stack[ToRS+(a)]) #define DS(a) (Stack[ToS-(a)]) /* various other command routines */ #define CODE(a) case(a): #define NEXT break #define JUMP(a) Object->ErrLine=(int)(a) #define XT(a) if(((a)>=(cell)Object->CodeSiz)||((a)<-1L))throw(M4BADTOK) #define VAR(a) if(((a)>=(cell)VarNum)||((a)<0L))throw(M4BADVAR) #define CSTR(a) if(((a)>=(cell)Object->StringSiz)||((a)<0L))throw(M4BADSTR) #define UVAR(a) if(((a)>=(cell)VarNum)||((a)=MAXDEVS))throw(M4BADDEV) #define UDEV(a) if(((a)<=COUT)||((a)>=MAXDEVS))throw(M4BADDEV) #define ODEV(a) if(Stream[(int)(a)].Device==NULL)throw(M4IOERR) #define SDEV(a) if(Stream[(int)(a)].Mode&F4_PIPE)throw(M4BADDEV) #ifdef __TURBOC__ /* TurboC supports no pipes */ #define NOPIPES #endif #ifdef __DJGPP__ /* can't get DJGPP to work */ #define NOPIPES #endif /* define 4tH I/O device */ typedef struct { char Mode; /* standard opening mode */ FILE* Device; /* external device opened */ FILE* (*Connect) (const char*, const char*); int (*Disconnect) (FILE *); /* device closing function */ } Dev4th; /* device standard opening table */ typedef struct { char Mode; /* standard opening mode */ char CMode [4]; /* C mode string mapping */ } Mode4th; /* 4tH I/O devices */ static Dev4th Stream [MAXDEVS]; static FILE *Channel [2] = {NULL, NULL}; static unsigned ToS, ToRS; /* top of stack/top of ret. stack */ static unsigned UnitSiz; /* size of Character Segment */ static unsigned VarNum; /* calculate number of variables */ static char Sleeping; /* VM is dormant if TRUE */ static cell *Vars; /* pointer to Variable Area */ static cell *Stack; /* pointer to stack */ static cell *Handler; /* throw handler */ static cell *Hld; /* equivalent of forth HLD */ static cell *Here; /* pointer to circular PAD buffer */ static cell *Base; /* radix status */ static Hcode *Applet; /* externalize Object */ static jmp_buf Thrown; /* buffer for throw error-return */ /* THROW prototype */ static void throw __PROTO((cell ErrCode)); #ifdef NOPIPES /* dummy pipe functions */ static FILE* Popen(const char* a, const char* b) { if (a==b); return (NULL); } static int Pclose(FILE *a) { if (a); return (0); } #else #ifdef UNIX /* more reasonable pclose */ #ifndef ARCHAIC static int Pclose (FILE *p) #else static int Pclose (p) FILE *p; #endif /* no error if child died */ { return ((pclose (p)) && (errno != ECHILD) ? -1 : 0); } #ifndef ARCHAIC /* relatively safe popen() */ static FILE *Popen (const char *f, const char *m) #else static FILE *Popen (f, m) const char *f; const char *m; #endif { FILE *p; /* filepointer to pipe */ long x; /* simple counter */ int s = 0; /* status of child */ p = popen (f, m); /* perform a normal popen() */ for (x = 0; x < PIPEWAIT && s == 0; x++) waitpid (-1, &s, WNOHANG); return (s ? NULL : p); /* check the status for a while */ } /* return NULL if not normal */ #else #ifdef _WIN32 /* use equivalent Win32 calls */ static FILE* Popen (const char* a, const char* b) { return (_popen (a, b)); } static int Pclose (FILE *a) { return (_pclose (a) == -1 ? -1 : 0); } #endif /* _pclose() returns -1 on error */ #endif #endif /* This routine saves a stackframe for PAUSE and CATCH. */ #ifndef ARCHAIC static void PushStackFrame (void) #else static void PushStackFrame () #endif { RFREE (3); RPUSH ((cell) ToS); RPUSH (*Handler); RPUSH ((cell) Applet->ErrLine); *Handler = ToRS; } /* This routine restores a stackframe for PAUSE and CATCH. */ #ifndef ARCHAIC static unsigned PopStackFrame (void) #else static unsigned PopStackFrame () #endif { /* handler contains RP */ if ((*Handler > R0) || (*Handler < (cell) ToS)) return (M4BADPTR); /* Return Stack may not collide */ ToRS = (unsigned) *Handler; /* restore RP from handler */ if (ToRS > (R0 - 3)) return (M4REMPTY); /* check if enough items on ret stack */ Applet->ErrLine = (int) RPOP + 1; *Handler = RPOP; /* retrieve handler from Return Stack */ ToS = (unsigned) RPOP; /* retrieve SP from Return Stack */ /* SP might have shrunk after CATCH */ if (ToS > ToRS) return (M4BADPTR); else return (M4NOERRS); /* SP may not violate Return Stack */ } /* This is the equivalent of Forths THROW. */ #ifndef ARCHAIC static void throw (cell ErrCode) #else static void throw (ErrCode) cell ErrCode; #endif { int Caller; /* temporary storage for return addr */ cell PopCode; /* What PopStackFrame() returns */ if (ErrCode) /* THROW 0 does nothing */ { if (*Handler) /* if a previous handler */ { /* handler contains RP */ Caller = Applet->ErrLine; if ((PopCode = (cell) PopStackFrame ()) != M4NOERRS) { /* invalid stack frame */ Applet->ErrLine = Caller; ErrCode = PopCode; /* update header vars */ } else { /* prepare to return */ DS (1) = -ErrCode; ErrCode = M4NOERRS; /* update error vars */ (Applet->ErrLine)++; /* increment PROGCOUNT */ } } /* no or invalid handler */ if ((ErrCode < 0) || (ErrCode > LastMsg4th)) Applet->ErrNo = M4THROW; else Applet->ErrNo = (unsigned) ErrCode; longjmp (Thrown, EXCEPTION); /* jump to main loop */ } } /* Gets a value from the String User Area */ #ifndef ARCHAIC static unit fetch (cell address) #else static unit fetch (address) cell address; #endif { if ((address >= TIB) && (address < UnitSiz)) return (Applet->UnitSeg [(unsigned) address]); else throw (M4BADADR); return (' '); } /* Stores a value in the String User Area */ #ifndef ARCHAIC static void store (cell address, unit value) #else static void store (address, value) cell address; unit value; #endif { if ((address >= TIB) && (address < UnitSiz)) Applet->UnitSeg [(unsigned) address] = value; else throw (M4BADADR); } /* This baby simply prints a single character. Equivalent of Forths EMIT */ #ifndef ARCHAIC static void emit (unit c) #else static void emit (c) unit c; #endif { if ((fputc ((int) c, Channel [COUT])) == EOF) throw (M4IOERR); } /* This routine reads J characters from input device DEV and places them at address I. It returns the number of characters actually read. Leaves ASCIIZ string when reading a textdevice. */ #ifndef ARCHAIC static cell Accept (cell i, cell j, char mode) #else static cell Accept (i, j, mode) cell i; cell j; char mode; #endif { int c; /* char read */ char OK = TRUE; /* OK to read next char */ cell t = 0; /* counter */ /* device is keyboard: textmode */ if (Vars [VCIN] == STD4IN) mode = 't'; do { c = fgetc (Channel [CIN]); /* get character */ if ((c == EOF) || ((mode == 't') && (c == (int) '\n'))) OK = FALSE; else if ((mode == 'b') || /* stop on EOF or in text mode */ ((c != (int) '\r') && (c != EOTu) && (c != EOTm))) { /* store the character and incr count */ store (i + t, (unit) c); /* when in binary mode or when in */ t++; /* textmode and no or EOF */ } /* has been read (these are skipped) */ } while ((OK) && (t < j)); /* until count reached or EOF */ /* when reading from keyboard */ if ((OK) && (Vars [VCIN] == STD4IN)) do { c = fgetc (Channel [CIN]); } while ((c != EOF) && (c != '\n')); /* empty buffer (read till ) */ if (mode == 't') { store (i + t, '\0'); /* when in text mode terminate string */ if ((t == 0) && (c == EOF)) return (-1); } /* return -1 when nothing read */ return (t); /* return #chars read */ } /* This function is roughly equivalent with Forths <# */ #ifndef ARCHAIC static void lsharp (void) #else static void lsharp () #endif { *Hld = (PAD + PADSIZ); store ((cell) --(*Hld), '\0'); } /* This function is equivalent with Forths SIGN */ #ifndef ARCHAIC static void sign (cell x) #else static void sign (x) cell x; #endif { if (x < 0) store ((cell) --(*Hld), '-'); } /* This function is roughly equivalent with Forths # */ #ifndef ARCHAIC static unit sharp (void) #else static unit sharp () #endif { unit y = 0; if ((*Base < 2) || (*Base > 36)) throw (M4BADRDX); if (ToS) { y = (unit) (DS (1) % *Base); DS (1) /= *Base; } else throw (M4SEMPTY); return (y += (y > 9) ? '7' : '0'); } /* This function is equivalent of Forths #S */ #ifndef ARCHAIC static void sharpS (void) #else static void sharpS () #endif { do store ((cell) --(*Hld), sharp ()); while (DS (1)); } /* This function prints y characters from address x. Equivalent of Forths TYPE. */ #ifndef ARCHAIC static void type (cell x, cell y) #else static void type (x, y) cell x; cell y; #endif { for (;y > 0; y--, x++) emit (fetch (x)); } /* Prints a number according to the current radix. Roughly equivalent to D.R */ #ifndef ARCHAIC static void dotR (cell n) #else static void dotR (n) cell n; #endif { cell t; DSIZE (1); if ((t = DS (1)) < 0) DS (1) = -(DS(1)); lsharp (); sharpS (); sign (t); DDROP; while (strlen ((char*) Applet->UnitSeg + (unsigned) *Hld) < n) store ((cell) --(*Hld), ' '); type ((cell) *Hld, (cell) (PAD + PADSIZ) - (*Hld + 1)); } /* This routine is a 'smart' implementation of CMOVE. */ #ifndef ARCHAIC static cell cmove (cell src, cell dst, cell cnt) #else static cell cmove (src, dst, cnt) cell src; cell dst; cell cnt; #endif { cell x = src + (cnt - 1); /* addr of last destination char */ cell y = dst + (cnt - 1); /* addr of last destination char */ unit *a = Applet->UnitSeg + (unsigned) src; /* temp pointer source */ unit *b = Applet->UnitSeg + (unsigned) dst; /* temp pointer destination */ if (cnt > 0) /* if there is anything to move */ { /* check source/dest. within limits */ if ((src >= TIB) && (src < UnitSiz) && (dst >= TIB) && (dst < UnitSiz) && (x >= TIB) && (x < UnitSiz) && (y >= TIB) && (y < UnitSiz)) { if (src < dst) /* are strings overlapping? */ { /* then reverse move */ a = Applet->UnitSeg + (unsigned) x; b = Applet->UnitSeg + (unsigned) y; while (cnt) { *b = *a; cnt--; a--; b--; } } else /* are strings not overlapping? */ { /* then start moving right away */ while (cnt) { *b = *a; cnt--; a++; b++; } } } else throw (M4BADADR); /* THROW when outside limits */ return (++y); /* return last address */ } else return (dst); /* else return destination address */ } /* This routine simply copies the string constant 'constr' to the PAD. Note that no checks are made here! */ #ifndef ARCHAIC static cell toPAD (char* constr) #else static cell toPAD (constr) char* constr; #endif { int len = strlen (constr); if ((*Here + len) > STRTOP) *Here = PAD; DPUSH (*Here); for (; *constr; constr++, (*Here)++) store (*Here, (unit) *constr); store ((*Here)++, '\0'); return (len); } /* This routine simply copies a string/count to the PAD and terminates it. */ #ifndef ARCHAIC static char* toCstring (cell str, cell cnt) #else static char* toCstring (str, cnt) cell str; cell cnt; #endif { unit *p; if ((*Here + cnt) > STRTOP) *Here = PAD; p = (Applet->UnitSeg + (unsigned) *Here); *Here = (unsigned) cmove (str, *Here, cnt); store ((*Here)++, '\0'); return ((char *) p); } /* This routine closes an input- or an output file. ErrCode determines which error is thrown. M4NOERRS will bypass the throw() routine and force the close. */ #ifndef ARCHAIC static void CloseStream (int StrNo, unsigned ErrCode) #else static void CloseStream (StrNo, ErrCode) int StrNo; unsigned ErrCode; #endif { UDEV (StrNo); /* is it a valid stream */ if (Stream [StrNo].Device != NULL) /* ignore unopened streams */ { if ((Stream [StrNo].Mode & F4_READ) && (Vars [VCIN] == StrNo)) { /* set CIN accordingly */ Channel [CIN] = stdin; Vars [VCIN] = STD4IN; } /* redirect output channel */ if ((Stream [StrNo].Mode & F4_WRITE) && (Vars [VCOUT] == StrNo)) { /* set COUT accordingly */ Channel [COUT] = stdout; Vars [VCOUT] = STD4OUT; } /* call appropriate method */ if (Stream [StrNo].Disconnect (Stream [StrNo].Device)) throw (ErrCode); Stream [StrNo].Device = NULL; /* signal external device closed */ } } /* This routine opens an input- or an output file. */ #ifndef ARCHAIC static cell OpenStream (char *Name, int Mode) #else static cell OpenStream (Name, Mode) char *Name; int Mode; #endif { #ifndef WEB4TH static Mode4th ModeList [] = { { F4_READ, "rb" }, { F4_WRITE, "wb" }, { F4_READ|F4_WRITE, "r+b" }, { F4_APPND|F4_WRITE, "ab" }, { F4_APPND|F4_WRITE|F4_READ, "a+b" }, #ifdef UNIX { F4_READ|F4_PIPE, "r" }, { F4_WRITE|F4_PIPE, "w" } #else { F4_READ|F4_PIPE, "rb" }, { F4_WRITE|F4_PIPE, "wb" } #endif }; static char Mapping [] ="\x0\x0\x1\x2\x3\x0\x3\x4\x5\x5\x6\x5\x6\x5\x6\x5"; int x; for (x = COUT + 1; x < MAXDEVS; x++) /* do not search CIN and COUT */ if (Stream [x].Device == NULL) /* find unopened stream */ { /* initialize stream */ Stream [x].Mode = ModeList [(int) Mapping [Mode]].Mode; Stream [x].Disconnect = (Stream [x].Mode & F4_PIPE ? Pclose : fclose); Stream [x].Connect = (Stream [x].Mode & F4_PIPE ? Popen : fopen); return (((Stream [x].Device = Stream [x].Connect (Name, ModeList [(int) Mapping [Mode]].CMode)) == NULL ? CELL_MIN : (cell) x )); } /* open stream */ #endif return (CELL_MIN); } /* Main routine and the only external. */ #ifndef ARCHAIC cell exec_4th (Hcode *Object, unsigned ArgN, char **ArgS, unsigned VarN, ...) #else cell exec_4th (Object, ArgN, ArgS, VarN) Hcode *Object; unsigned ArgN; char **ArgS; unsigned VarN; #endif { unsigned VarMax; /* maximum number of C variables */ unsigned x; /* temporary counter */ cell a, b, c; /* internal stack variables */ time_t Now; /* temporary time variable */ unit t; /* temporary char */ char *p, *q; /* temporary pointers */ cell *In; /* equivalent of forth >IN */ va_list Vals; /* list of preloaded variables */ if (! Object) return (CELL_MIN); /* check if object is reliable */ else if (! Object->Reliable) return (CELL_MIN); srand (SEED); /* initialize randomizer */ /* initialize main variables */ Applet = Object; /* externalize argument */ Sleeping = FALSE; /* not a dormant VM */ ToRS = R0; /* reset return stack pointer */ ToS = S0; /* reset stackpointer */ UnitSiz = Object->Strings + TIBSIZ + PADSIZ; /* calculate size Unit Segment */ for (x = CIN; x < MAXDEVS; x++) Stream [x].Device = NULL; Channel [CIN] = Stream [CIN].Device = stdin; Channel [COUT] = Stream [COUT].Device = stdout; Stream [CIN].Mode = F4_READ; Stream [COUT].Mode = F4_WRITE; /* read and write from tty */ if (Object->Offset == 0) { /* start a new VM */ VarMax = Object->Offset = VarN + VAR4TH; VarNum = Object->Variables + Object->Offset; /* reserve space for BASE, >IN */ Object->ErrNo = M4NOERRS; /* reset errorcode */ Object->ErrLine = 0; /* reset linepointer */ if ((Object->CellSeg = Stack = (cell*) calloc (STACKSIZ + SYS4TH + VarNum, sizeof (cell))) == NULL) { /* allocate Integer Segment */ Object->ErrNo = M4NOMEM; return (CELL_MIN); } if ((Object->UnitSeg = (unit*) calloc (UnitSiz + 1, sizeof (unit))) == NULL) { /* allocate Character Segment */ free (Stack); Object->ErrNo = M4NOMEM; return (CELL_MIN); } /* assign hidden variables */ Handler = Stack + STACKSIZ; /* assign pointer to HANDLER */ Here = Handler + 1; /* assign pointer to HERE */ Hld = Here + 1; /* assign pointer to HLD */ *Handler = 0; /* initialize HANDLER */ *Here = PAD; /* initialize HERE to PAD */ /* set pointer to Variable Area */ Vars = Stack + STACKSIZ + SYS4TH; /* preload variables and environs */ Vars [VBASE] = 10L; /* initialize BASE */ Vars [VIN] = 0L; /* initialize >IN */ Vars [VOUT] = CELL_MIN; /* initialize OUT */ Vars [VTIB] = TIB; /* initialize SOURCE, TIB address */ Vars [VTIBS] = TIBSIZ; /* initialize SOURCE, TIB size */ Vars [VHI] = (cell) UnitSiz - 1; Vars [VFIRST] = (cell) Object->Offset; Vars [VLAST] = (cell) VarNum - 1; } /* end of new VM */ else { /* revive a dormant VM */ Stack = Object->CellSeg; /* setup CellSegment areas */ Vars = Stack + STACKSIZ + SYS4TH; /* set pointer to Variable Area */ Handler = Stack + STACKSIZ; /* assign pointer to HANDLER */ Here = Handler + 1; /* assign pointer to HERE */ Hld = Here + 1; /* assign pointer to HLD */ /* now retrieve all variables */ Object->ErrNo = PopStackFrame (); /* calculate Var Area variables */ VarNum = Object->Variables + Object->Offset; VarMax = ((VarN + VAR4TH) > Object->Offset ? Object->Offset : (VarN + VAR4TH)); } /* depends on smallest value */ /* end of dormant VM */ va_start (Vals, VarN); /* copy C variables */ for (x = VAR4TH; x < VarMax; x++) Vars [x] = va_arg (Vals, cell); va_end (Vals); Vars [VCIN] = STD4IN; /* signal channel-in is stdin */ Vars [VCOUT] = STD4OUT; /* signal channel-out is stdout */ Base = &(Vars [VBASE]); /* assign pointer to BASE */ In = &(Vars [VIN]); /* assign pointer to >IN */ /* This is the main calculation engine. Most operators can be reduced to pop() and push() calls. It executes until there are no more operators left or QUIT is called. */ (void) setjmp (Thrown); /* Return from error */ if ((! Object->ErrNo) && (Object->ErrLine >= 0)) for (;(Object->ErrLine < Object->CodeSiz); Object->ErrLine++) switch (Object->CodeSeg [Object->ErrLine].Word) { CODE (CELLD) CODE (STRINGD) NEXT; CODE (LITERAL) DFREE (1); DPUSH (OPERAND); NEXT; CODE (BRANCH) JUMP (OPERAND); NEXT; CODE (BRANCH0) DSIZE (1); if (DPOP == F_F) JUMP (OPERAND); NEXT; CODE (LOOP) RSIZE (2); if (++(RS (1)) < RS (2)) JUMP (OPERAND); else { RDROP; RDROP; } NEXT; CODE (DO) DSIZE (2); a = DPOP; RPUSH (DPOP); RPUSH (a); NEXT; CODE (CALL) RFREE (1); RPUSH ((cell) PROGCOUNT); JUMP (OPERAND); NEXT; CODE (EXIT) RSIZE (1); a = RPOP; XT (a); JUMP (a); NEXT; CODE (DUP) DSIZE (1); DFREE (1); a = DS(1); DPUSH (a); NEXT; CODE (DROP) DSIZE (1); DDROP; NEXT; CODE (SWAP) DSIZE (2); a = DS (1); DS (1) = DS (2); DS (2) = a; NEXT; CODE (ROT) DSIZE (3); a = DS (1); DS (1) = DS (3); DS (3) = DS (2); DS (2) = a; NEXT; CODE (OVER) DSIZE (2); DFREE (1); a = DS (2); DPUSH (a); NEXT; CODE (VARIABLE) DFREE (1); DPUSH ((cell) Object->Offset + OPERAND); NEXT; CODE (VALUE) DFREE (1); DPUSH (Vars [Object->Offset + (unsigned) OPERAND]); NEXT; CODE (RCOPY) RSIZE (1); DFREE (1); DPUSH (RS (1)); NEXT; CODE (RGET) RSIZE (1); DPUSH (RPOP); NEXT; CODE (RPUT) DSIZE (1); RPUSH (DPOP); NEXT; CODE (STORE) DSIZE (2); a = DPOP; UVAR (a); Vars [(unsigned) a] = DPOP; NEXT; CODE (FETCH) DSIZE (1); a = DS (1); VAR (a); DS (1) = Vars [(unsigned) a]; NEXT; CODE (ADDSTORE) DSIZE (2); a = DPOP; UVAR (a); Vars [(unsigned) a] += DPOP; NEXT; CODE (QDO) DSIZE (2); a = DPOP; b = DPOP; if (a == b) JUMP (OPERAND); else { RPUSH (b); RPUSH (a); } NEXT; CODE (PLOOP) RSIZE (2); DSIZE (1); RS (1) += DPOP; if ((DS(0) > 0L) ? (RS(1) < RS(2)) : (RS(1) > RS(2))) JUMP (OPERAND); else { RDROP; RDROP; } NEXT; CODE (LEAVE) RSIZE (2); RS (1) = RS (2); NEXT; CODE (EQ0) DSIZE (1); DS (1) = DS (1) == 0L ? F_T : F_F; NEXT; CODE (NE0) DSIZE (1); DS (1) = DS (1) != 0L ? F_T : F_F; NEXT; CODE (PLUS) DSIZE (2); DDROP; DS (1) += DS (0); NEXT; CODE (EQ) DSIZE (2); DDROP; DS (1) = DS (1) == DS (0) ? F_T : F_F; NEXT; CODE (MOD) DSIZE (2); if (DPOP != 0L) DS(1) %= DS(0); else throw (M4DIVBY0); NEXT; CODE (MINUS) DSIZE (2); DDROP; DS (1) -= DS (0); NEXT; CODE (INC) DSIZE (1); (DS (1))++; NEXT; CODE (DEC) DSIZE (1); (DS (1))--; NEXT; CODE (MUL) DSIZE (2); DDROP; DS (1) *= DS (0); NEXT; CODE (DIV) DSIZE (2); if (DPOP != 0L) DS (1) /= DS (0); else throw (M4DIVBY0); NEXT; CODE (RIGHT2) DSIZE (1); DS (1) >>= 1L; NEXT; CODE (SLASHMOD) DSIZE (2); if (DS (1) != 0L) { a = DS (2); DS (2) %= DS (1); DS (1) = a / DS (1); } else throw (M4DIVBY0); NEXT; CODE (GT) DSIZE (2); DDROP; DS (1) = DS (1) > DS (0) ? F_T : F_F; NEXT; CODE (MIN) DSIZE (2); DDROP; if (DS (1) > DS (0)) DS (1) = DS (0); NEXT; CODE (MAX) DSIZE (2); DDROP; if (DS (1) < DS (0)) DS (1) = DS (0); NEXT; CODE (STARSLSH) DSIZE (3); if (DPOP != 0L) { DS (2) *= DS (1); DS (2) /= DS (0); DDROP; } else throw (M4DIVBY0); NEXT; CODE (LEFT2) DSIZE (1); DS (1) <<= 1L; NEXT; CODE (ABS) DSIZE (1); if (DS (1) < 0) DS (1) = -(DS (1)); NEXT; CODE (NEGATE) DSIZE (1); DS (1) = -(DS (1)); NEXT; CODE (OR) DSIZE (2); DDROP; DS (1) |= DS (0); NEXT; CODE (AND) DSIZE (2); DDROP; DS (1) &= DS (0); NEXT; CODE (XOR) DSIZE (2); DDROP; DS (1) ^= DS (0); NEXT; CODE (SHIFT) DSIZE (2); DDROP; DS(1) = DS(0) < 0L ? DS(1) >> -(DS(0)) : DS(1) << DS(0); NEXT; CODE (INVERT) DSIZE (1); DS (1) = ~(DS (1)); NEXT; CODE (LT) DSIZE (2); DDROP; DS (1) = DS (1) < DS (0) ? F_T : F_F; NEXT; CODE (NE) DSIZE (2); DDROP; DS (1) = DS (1) != DS (0) ? F_T : F_F; NEXT; CODE (LT0) DSIZE (1); DS (1) = DS (1) < 0L ? F_T : F_F; NEXT; CODE (GT0) DSIZE (1); DS (1) = DS (1) > 0L ? F_T : F_F; NEXT; CODE (RCOPY3) RSIZE (3); DFREE (1); DPUSH (RS (3)); NEXT; CODE (PRINT) for (p = Object->StringSeg + (unsigned) OPERAND; *p; p++) emit ((unit) *p); NEXT; CODE (CR) #ifndef UNIX if (Vars [VCOUT] != STD4OUT) emit ('\r'); #endif emit ('\n'); NEXT; CODE (SPACES) DSIZE (1); DDROP; for (a = 0L; a < DS (0); a++) emit (' '); NEXT; CODE (DOT) dotR (0); emit (' '); NEXT; CODE (DOTR) DSIZE (1); dotR (DPOP); NEXT; CODE (EMIT) DSIZE (1); emit ((unit) DPOP); NEXT; CODE (TO) DSIZE (1); Vars [Object->Offset + (unsigned) OPERAND] = DPOP; NEXT; CODE (VECTOR) RFREE (1); RPUSH ((cell) PROGCOUNT); XT (Vars [Object->Offset + (unsigned) OPERAND]); JUMP (Vars [Object->Offset + (unsigned) OPERAND]); NEXT; CODE (EXECUTE) DSIZE (1); RPUSH ((cell) PROGCOUNT); a = DPOP; XT (a); JUMP (a); NEXT; CODE (FETCHC) DSIZE (1); a = DPOP; if ((a < 0L) || (a >= (cell) Object->CodeSiz)) throw (M4BADTOK); else { b = Object->CodeSeg [(int) a].Value; if (Object->CodeSeg [(int) a].Word == STRINGD) (void) toPAD (Object->StringSeg + (unsigned) b); else DPUSH (b); } NEXT; CODE (TIME) DFREE (1); DPUSH ((cell) time (&Now)); NEXT; CODE (RANDOM) DFREE (1); DPUSH ((cell) (rand () & RNDMASK)); NEXT; CODE (CFETCH) DSIZE (1); DS (1) = (cell) fetch (DS (1)); NEXT; CODE (CSTORE) DSIZE (2); a = DPOP; store (a, (unit) DPOP); NEXT; CODE (LSHARP) lsharp (); NEXT; CODE (RSHARP) DSIZE (1); DFREE (1); DDROP; DPUSH ((cell) *Hld); DPUSH ((cell) (PAD + PADSIZ) - (*Hld + 1)); NEXT; CODE (HOLD) DSIZE (1); store ((cell) --(*Hld), (unit) DPOP); NEXT; CODE (SIGN) DSIZE (2); sign (DS (2)); DS (2) = DS (1); DDROP; NEXT; CODE (SHARP) DSIZE (1); store ((cell) --(*Hld), sharp ()); NEXT; CODE (SHARPS) DSIZE (1); sharpS (); NEXT; CODE (TYPE) DSIZE (2); a = DPOP; type (DPOP, a); NEXT; CODE (FILL) DSIZE (3); t = (unit) DPOP; a = DPOP; b = DPOP; for (;a > 0; a--, b++) store (b, t); NEXT; CODE (COUNT) DSIZE (1); DFREE (1); a = DS (1); if ((a >= TIB) && (a < UnitSiz)) DPUSH ((cell) strlen ((char*) Object->UnitSeg + (unsigned) a)); else throw (M4BADADR); NEXT; CODE (NUMBER) if ((*Base < 2) || (*Base > 36)) throw (M4BADRDX); else { DSIZE (2); q = toCstring (DS (2), DS (1)); a = strtoc (q, &p, (int) *Base); DDROP; DS (1) = ((p == (q + strlen (q))) && (strlen (q) > 0)) ? a : CELL_MIN; } NEXT; CODE (OMIT) DSIZE (1); do t = fetch (Vars [VTIB] + ((*In)++)); while ((t == (unit) DS (1)) && (t)); --(*In); DDROP; NEXT; CODE (PARSE) DSIZE (1); DFREE (1); a = DPOP; b = 0L; c = Vars [VTIB]; DPUSH (c + (*In)); do { t = fetch (c + ((*In)++)); b++; } while ((t != (unit) a) && (t)); if (! t) --(*In); DPUSH ((cell) --b); NEXT; CODE (CMOVE) DSIZE (3); a = DPOP; b = DPOP; (void) cmove (DPOP, b, a); NEXT; CODE (PLACE) DSIZE (3); a = DPOP; b = DPOP; store (cmove (DPOP, a, b), '\0'); NEXT; CODE (TRAILING) DSIZE (2); do (DS (1))--; while ((DS (1) >= 0) && (fetch (DS (2) + DS (1)) == ' ')); ++(DS (1)); NEXT; CODE (ACCEPT) DSIZE (2); DS (2) = Accept (DS (2), DS (1), 'b'); DDROP; NEXT; CODE (REFILL) DFREE (1); DPUSH (Accept (Vars [VTIB], Vars [VTIBS] - 1, 't') == -1 ? F_F : F_T); *In = 0L; NEXT; CODE (THROW) DSIZE (1); throw (-(DPOP)); NEXT; CODE (CATCH) DSIZE (1); XT (DS (1)); PushStackFrame (); JUMP (DPOP); NEXT; CODE (CAUGHT) RSIZE (2); *Handler = (unsigned) RPOP; RDROP; DPUSH (0L); NEXT; CODE (ENVIRON) DFREE (1); DPUSH (Vars [(unsigned) OPERAND]); NEXT; CODE (PLITERAL) DSIZE (1); DS (1) += OPERAND; NEXT; CODE (SPFETCH) DFREE (1); a = ToS; DPUSH (a); NEXT; CODE (RPFETCH) DFREE (1); DPUSH ((cell) ToRS); NEXT; CODE (RADIX) *Base = OPERAND; NEXT; CODE (OFFSET) DSIZE (1); a = DS (1) + OPERAND; CSTR (a); DS (1) = (cell) Object->StringSeg [(unsigned) a]; NEXT; CODE (PAUSE) PushStackFrame (); Sleeping = TRUE; CODE (QUIT) PROGCOUNT = Object->CodeSiz - 1; NEXT; CODE (ARGN) DFREE (1); DPUSH ((cell) ArgN); NEXT; CODE (SQUOTE) DFREE (2); a = toPAD (Object->StringSeg + (unsigned) OPERAND); DPUSH (a); NEXT; CODE (ARGS) DSIZE (1); DFREE (1); a = DPOP; if ((a < 0) || (a >= ArgN)) throw (M4BADSTR); else { a = toPAD (ArgS [(unsigned) a]); DPUSH (a); } NEXT; CODE (USE) DSIZE (1); a = DPOP; DEV (a); ODEV (a); if (Stream [(int) a].Mode & F4_READ) { Channel [CIN] = Stream [(int) a].Device; Vars [VCIN] = a; } if (Stream [(int) a].Mode & F4_WRITE) { Channel [COUT] = Stream [(int) a].Device; Vars [VCOUT] = a; } NEXT; CODE (FCLOSE) DSIZE (1); CloseStream ((int) DPOP, M4IOERR); NEXT; CODE (FSYNC) fflush (Channel [COUT]); NEXT; CODE (FTELL) DSIZE (1); a = DPOP; UDEV (a); ODEV (a); SDEV (a); b = (cell) ftell (Stream [(int) a].Device); if (b == -1L) throw (M4IOERR); else DPUSH (b); NEXT; CODE (FSEEK) DSIZE (2); a = DPOP; b = DPOP; UDEV (a); ODEV (a); SDEV (a); c = b < 0L ? SEEK_END : SEEK_SET; a = (cell) fseek (Stream [(int) a].Device, (long) b, (int) c) == 0 ? F_F : F_T; DPUSH (a); NEXT; CODE (FOPEN) DSIZE (3); a = DPOP; b = DPOP; c = DPOP; p = toCstring (c, b); a &= (F4_READ|F4_WRITE|F4_APPND|F4_PIPE); b = OpenStream (p, (int) a); DPUSH (b); NEXT; default: throw (M4BADOBJ); NEXT; } /* close files forced */ for (a = (cell) (COUT + 1); a < MAXDEVS; a++) CloseStream ((int) a, M4NOERRS); a = Vars [VOUT]; /* get result from OUT */ if (Sleeping == FALSE) /* if not PAUSEing */ { /* free environment */ free (Object->UnitSeg); free (Object->CellSeg); Object->UnitSeg = NULL; Object->CellSeg = NULL; Object->Offset = 0; } if (Object->ErrNo) return (CELL_MIN); else return (a); /* return value */ }