diff options
Diffstat (limited to 'src/runtime')
41 files changed, 400 insertions, 5437 deletions
diff --git a/src/runtime/Makefile b/src/runtime/Makefile index ffa63e8..c47c14e 100644 --- a/src/runtime/Makefile +++ b/src/runtime/Makefile @@ -3,512 +3,55 @@ include ../../Makedefs -HDRS = ../h/define.h ../h/config.h ../h/typedefs.h ../h/monitor.h\ +HDRS = ../h/define.h ../h/arch.h ../h/config.h ../h/typedefs.h \ ../h/cstructs.h ../h/cpuconf.h ../h/grttin.h\ ../h/rmacros.h ../h/rexterns.h ../h/rstructs.h \ ../h/rproto.h ../h/mproto.h ../h/sys.h -GRAPHICSHDRS = ../h/graphics.h ../h/xwin.h ../h/mswin.h +GHDRS = ../h/graphics.h ../h/xwin.h ../h/mswin.h COBJS = ../common/long.o ../common/time.o \ ../common/rswitch.o ../common/xwindow.o \ ../common/alloc.o ../common/filepart.o ../common/munix.o +XOBJS = cnv.o data.o def.o errmsg.o fconv.o fload.o fmath.o\ + fmisc.o fscan.o fstr.o fstranl.o fstruct.o fsys.o\ + fwindow.o imain.o imisc.o init.o interp.o invoke.o\ + keyword.o lmisc.o oarith.o oasgn.o ocat.o ocomp.o\ + omisc.o oref.o oset.o ovalue.o ralc.o rcoexpr.o rcomp.o\ + rdebug.o rexternal.o rlrgint.o rmemmgt.o rmisc.o rstruct.o \ + rsys.o rwinrsc.o rwinsys.o rwindow.o rcolor.o rimage.o -default: iconx -all: iconx comp_all +RTT = ../rtt/rtt +SUFFIXES = .r .c .o +.r.o: ; $(RTT) -x $*.r && $(CC) -o $*.o -c $(CFLAGS) x$*.c && rm x$*.c +.r.c: ; $(RTT) -x $*.r -$(COBJS): - cd ../common; $(MAKE) - - -#################################################################### -# -# Make entries for iconx -# - -XOBJS = xcnv.o xdata.o xdef.o xerrmsg.o xextcall.o xfconv.o xfload.o xfmath.o\ - xfmisc.o xfmonitr.o xfscan.o xfstr.o xfstranl.o xfstruct.o xfsys.o\ - xfwindow.o ximain.o ximisc.o xinit.o xinterp.o xinvoke.o\ - xkeyword.o xlmisc.o xoarith.o xoasgn.o xocat.o xocomp.o\ - xomisc.o xoref.o xoset.o xovalue.o xralc.o xrcoexpr.o xrcomp.o\ - xrdebug.o xrlrgint.o xrmemmgt.o xrmisc.o xrstruct.o xrsys.o\ - xrwinrsc.o xrwinsys.o xrwindow.o xrcolor.o xrimage.o - -OBJS = $(XOBJS) $(COBJS) -iconx: $(OBJS) +iconx: $(COBJS) $(XOBJS) cd ../common; $(MAKE) - $(CC) $(RLINK) -o iconx $(OBJS) $(XL) $(RLIBS) $(TL) + $(CC) $(RLINK) -o iconx $(XOBJS) $(COBJS) $(XL) $(RLIBS) $(TLIBS) cp iconx ../../bin strip $(SFLAGS) ../../bin/iconx$(EXE) -xcnv.o: cnv.r $(HDRS) - ../../bin/rtt -x cnv.r - $(CC) -c $(CFLAGS) xcnv.c - rm xcnv.c - -xdata.o: data.r $(HDRS) ../h/kdefs.h ../h/fdefs.h ../h/odefs.h - ../../bin/rtt -x data.r - $(CC) -c $(CFLAGS) xdata.c - rm xdata.c - -xdef.o: def.r $(HDRS) - ../../bin/rtt -x def.r - $(CC) -c $(CFLAGS) xdef.c - rm xdef.c - -xerrmsg.o: errmsg.r $(HDRS) - ../../bin/rtt -x errmsg.r - $(CC) -c $(CFLAGS) xerrmsg.c - rm xerrmsg.c - -xextcall.o: extcall.r $(HDRS) - ../../bin/rtt -x extcall.r - $(CC) -c $(CFLAGS) xextcall.c - rm xextcall.c - -xfconv.o: fconv.r $(HDRS) - ../../bin/rtt -x fconv.r - $(CC) -c $(CFLAGS) xfconv.c - rm xfconv.c - -xfload.o: fload.r $(HDRS) - ../../bin/rtt -x fload.r - $(CC) -c $(CFLAGS) xfload.c - rm xfload.c - -xfmath.o: fmath.r $(HDRS) - ../../bin/rtt -x fmath.r - $(CC) -c $(CFLAGS) xfmath.c - rm xfmath.c - -xfmisc.o: fmisc.r $(HDRS) - ../../bin/rtt -x fmisc.r - $(CC) -c $(CFLAGS) xfmisc.c - rm xfmisc.c - -xfmonitr.o: fmonitr.r $(HDRS) - ../../bin/rtt -x fmonitr.r - $(CC) -c $(CFLAGS) xfmonitr.c - rm xfmonitr.c - -xfscan.o: fscan.r $(HDRS) - ../../bin/rtt -x fscan.r - $(CC) -c $(CFLAGS) xfscan.c - rm xfscan.c - -xfstr.o: fstr.r $(HDRS) - ../../bin/rtt -x fstr.r - $(CC) -c $(CFLAGS) xfstr.c - rm xfstr.c - -xfstranl.o: fstranl.r $(HDRS) - ../../bin/rtt -x fstranl.r - $(CC) -c $(CFLAGS) xfstranl.c - rm xfstranl.c - -xfstruct.o: fstruct.r $(HDRS) - ../../bin/rtt -x fstruct.r - $(CC) -c $(CFLAGS) xfstruct.c - rm xfstruct.c - -xfsys.o: fsys.r $(HDRS) - ../../bin/rtt -x fsys.r - $(CC) -c $(CFLAGS) xfsys.c - rm xfsys.c - -xfwindow.o: fwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x fwindow.r - $(CC) -c $(CFLAGS) xfwindow.c - rm xfwindow.c - -ximain.o: imain.r $(HDRS) ../h/version.h - ../../bin/rtt -x imain.r - $(CC) -c $(CFLAGS) ximain.c - rm ximain.c - -ximisc.o: imisc.r $(HDRS) - ../../bin/rtt -x imisc.r - $(CC) -c $(CFLAGS) ximisc.c - rm ximisc.c - -xinit.o: init.r $(HDRS) ../h/odefs.h ../h/version.h - ../../bin/rtt -x init.r - $(CC) -c $(CFLAGS) xinit.c - rm xinit.c - -xinterp.o: interp.r $(HDRS) - ../../bin/rtt -x interp.r - $(CC) -c $(CFLAGS) xinterp.c - rm xinterp.c - -xinvoke.o: invoke.r $(HDRS) - ../../bin/rtt -x invoke.r - $(CC) -c $(CFLAGS) xinvoke.c - rm xinvoke.c - -xkeyword.o: keyword.r $(HDRS) ../h/features.h ../h/version.h - ../../bin/rtt -x keyword.r - $(CC) -c $(CFLAGS) xkeyword.c - rm xkeyword.c - -xlmisc.o: lmisc.r $(HDRS) - ../../bin/rtt -x lmisc.r - $(CC) -c $(CFLAGS) xlmisc.c - rm xlmisc.c - -xoarith.o: oarith.r $(HDRS) - ../../bin/rtt -x oarith.r - $(CC) -c $(CFLAGS) xoarith.c - rm xoarith.c - -xoasgn.o: oasgn.r $(HDRS) - ../../bin/rtt -x oasgn.r - $(CC) -c $(CFLAGS) xoasgn.c - rm xoasgn.c - -xocat.o: ocat.r $(HDRS) - ../../bin/rtt -x ocat.r - $(CC) -c $(CFLAGS) xocat.c - rm xocat.c - -xocomp.o: ocomp.r $(HDRS) - ../../bin/rtt -x ocomp.r - $(CC) -c $(CFLAGS) xocomp.c - rm xocomp.c - -xomisc.o: omisc.r $(HDRS) - ../../bin/rtt -x omisc.r - $(CC) -c $(CFLAGS) xomisc.c - rm xomisc.c - -xoref.o: oref.r $(HDRS) - ../../bin/rtt -x oref.r - $(CC) -c $(CFLAGS) xoref.c - rm xoref.c - -xoset.o: oset.r $(HDRS) - ../../bin/rtt -x oset.r - $(CC) -c $(CFLAGS) xoset.c - rm xoset.c - -xovalue.o: ovalue.r $(HDRS) - ../../bin/rtt -x ovalue.r - $(CC) -c $(CFLAGS) xovalue.c - rm xovalue.c - -xralc.o: ralc.r $(HDRS) - ../../bin/rtt -x ralc.r - $(CC) -c $(CFLAGS) xralc.c - rm xralc.c - -xrcoexpr.o: rcoexpr.r $(HDRS) - ../../bin/rtt -x rcoexpr.r - $(CC) -c $(CFLAGS) xrcoexpr.c - rm xrcoexpr.c - -xrcomp.o: rcomp.r $(HDRS) - ../../bin/rtt -x rcomp.r - $(CC) -c $(CFLAGS) xrcomp.c - rm xrcomp.c - -xrdebug.o: rdebug.r $(HDRS) - ../../bin/rtt -x rdebug.r - $(CC) -c $(CFLAGS) xrdebug.c - rm xrdebug.c - -xrlrgint.o: rlrgint.r $(HDRS) - ../../bin/rtt -x rlrgint.r - $(CC) -c $(CFLAGS) xrlrgint.c - rm xrlrgint.c - -xrmemmgt.o: rmemmgt.r $(HDRS) - ../../bin/rtt -x rmemmgt.r - $(CC) -c $(CFLAGS) xrmemmgt.c - rm xrmemmgt.c - -xrmisc.o: rmisc.r $(HDRS) - ../../bin/rtt -x rmisc.r - $(CC) -c $(CFLAGS) xrmisc.c - rm xrmisc.c - -xrstruct.o: rstruct.r $(HDRS) - ../../bin/rtt -x rstruct.r - $(CC) -c $(CFLAGS) xrstruct.c - rm xrstruct.c - -xrsys.o: rsys.r $(HDRS) - ../../bin/rtt -x rsys.r - $(CC) -c $(CFLAGS) xrsys.c - rm xrsys.c - -xrwinrsc.o: rwinrsc.r $(HDRS) $(GRAPHICSHDRS) rxrsc.ri - ../../bin/rtt -x rwinrsc.r - $(CC) -c $(CFLAGS) xrwinrsc.c - rm xrwinrsc.c - -xrwinsys.o: rwinsys.r $(HDRS) $(GRAPHICSHDRS) rxwin.ri - ../../bin/rtt -x rwinsys.r - $(CC) -c $(CFLAGS) xrwinsys.c - rm xrwinsys.c - -xrwindow.o: rwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rwindow.r - $(CC) -c $(CFLAGS) xrwindow.c - rm xrwindow.c - -xrcolor.o: rcolor.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rcolor.r - $(CC) -c $(CFLAGS) xrcolor.c - rm xrcolor.c - -xrimage.o: rimage.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rimage.r - $(CC) -c $(CFLAGS) xrimage.c - rm xrimage.c - - -#################################################################### -# -# Make entries for the compiler library -# - -comp_all: $(COBJS) db_lib - -db_lib: rt.db rt.a - -# -# if rt.db is missing or any header files have been updated, recreate -# rt.db from scratch along with the .o files. -# -rt.db: $(HDRS) - rm -f rt.db rt.a - ../../bin/rtt cnv.r data.r def.r errmsg.r fconv.r fload.r fmath.r\ - fmisc.r fmonitr.r fscan.r fstr.r fstranl.r fstruct.r\ - fsys.r fwindow.r init.r invoke.r keyword.r\ - lmisc.r oarith.r oasgn.r ocat.r ocomp.r omisc.r\ - oref.r oset.r ovalue.r ralc.r rcoexpr.r rcomp.r\ - rdebug.r rlrgint.r rmemmgt.r rmisc.r rstruct.r\ - rsys.r rwinrsc.r rwinsys.r rwindow.r rcolor.r rimage.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rt.a: ../common/rswitch.o ../common/long.o ../common/time.o\ - cnv.o data.o def.o errmsg.o fconv.o fload.o fmath.o fmisc.o fmonitr.o \ - fscan.o fstr.o fstranl.o fstruct.o fsys.o fwindow.o init.o invoke.o\ - keyword.o lmisc.o oarith.o oasgn.o ocat.o ocomp.o omisc.o oref.o oset.o\ - ovalue.o ralc.o rcoexpr.o rcomp.o rdebug.o rlrgint.o rmemmgt.o\ - rmisc.o rstruct.o rsys.o rwinrsc.o rwinsys.o\ - rwindow.o rcolor.o rimage.o ../common/xwindow.o ../common/alloc.o - rm -f rt.a - ar qc rt.a `sed 's/$$/.o/' rttcur.lst` ../common/rswitch.o\ - ../common/long.o ../common/time.o\ - ../common/xwindow.o ../common/alloc.o - ranlib rt.a 2>/dev/null || : - cp -p rt.a rt.db ../common/dlrgint.o ../../bin - -cnv.o: cnv.r $(HDRS) - ../../bin/rtt cnv.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -data.o: data.r $(HDRS) - ../../bin/rtt data.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -def.o: def.r $(HDRS) - ../../bin/rtt def.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -errmsg.o: errmsg.r $(HDRS) - ../../bin/rtt errmsg.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fconv.o: fconv.r $(HDRS) - ../../bin/rtt fconv.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fload.o: fload.r $(HDRS) - ../../bin/rtt fload.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmath.o: fmath.r $(HDRS) - ../../bin/rtt fmath.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmisc.o: fmisc.r $(HDRS) - ../../bin/rtt fmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmonitr.o: fmonitr.r $(HDRS) - ../../bin/rtt fmonitr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fscan.o: fscan.r $(HDRS) - ../../bin/rtt fscan.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstr.o: fstr.r $(HDRS) - ../../bin/rtt fstr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstranl.o: fstranl.r $(HDRS) - ../../bin/rtt fstranl.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstruct.o: fstruct.r $(HDRS) - ../../bin/rtt fstruct.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fsys.o: fsys.r $(HDRS) - ../../bin/rtt fsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fwindow.o: fwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt fwindow.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -init.o: init.r $(HDRS) - ../../bin/rtt init.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -invoke.o: invoke.r $(HDRS) - ../../bin/rtt invoke.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -keyword.o: keyword.r $(HDRS) - ../../bin/rtt keyword.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -lmisc.o: lmisc.r $(HDRS) - ../../bin/rtt lmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oarith.o: oarith.r $(HDRS) - ../../bin/rtt oarith.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oasgn.o: oasgn.r $(HDRS) - ../../bin/rtt oasgn.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ocat.o: ocat.r $(HDRS) - ../../bin/rtt ocat.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ocomp.o: ocomp.r $(HDRS) - ../../bin/rtt ocomp.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -omisc.o: omisc.r $(HDRS) - ../../bin/rtt omisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oref.o: oref.r $(HDRS) - ../../bin/rtt oref.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oset.o: oset.r $(HDRS) - ../../bin/rtt oset.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ovalue.o: ovalue.r $(HDRS) - ../../bin/rtt ovalue.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ralc.o: ralc.r $(HDRS) - ../../bin/rtt ralc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rcoexpr.o: rcoexpr.r $(HDRS) - ../../bin/rtt rcoexpr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rcomp.o: rcomp.r $(HDRS) - ../../bin/rtt rcomp.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rdebug.o: rdebug.r $(HDRS) - ../../bin/rtt rdebug.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +$(COBJS): + cd ../common; $(MAKE) -rlrgint.o: rlrgint.r $(HDRS) - ../../bin/rtt rlrgint.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` -rmemmgt.o: rmemmgt.r $(HDRS) - ../../bin/rtt rmemmgt.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +$(XOBJS): $(HDRS) $(GHDRS) -rmisc.o: rmisc.r $(HDRS) - ../../bin/rtt rmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +data.o: ../h/fdefs.h ../h/odefs.h ../h/kdefs.h -rstruct.o: rstruct.r $(HDRS) - ../../bin/rtt rstruct.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +fmisc.o: ../h/opdefs.h -rsys.o: rsys.r $(HDRS) - ../../bin/rtt rsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +imain.o: ../h/version.h ../h/header.h ../h/opdefs.h ../h/version.h -rwinrsc.o: rwinrsc.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwinrsc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +init.o: ../h/header.h ../h/odefs.h ../h/version.h -rwinsys.o: rwinsys.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwinsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +keyword.o: ../h/kdefs.h ../h/features.h ../h/version.h -rwindow.o: rwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwindow.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rdebug.o: ../h/opdefs.h -rcolor.o: rcolor.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rcolor.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rwinrsc.o: rxrsc.ri -rimage.o: rimage.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rimage.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rwinsys.o: rxwin.ri rmswin.ri diff --git a/src/runtime/cnv.r b/src/runtime/cnv.r index 23e1767..5661deb 100644 --- a/src/runtime/cnv.r +++ b/src/runtime/cnv.r @@ -14,9 +14,6 @@ * Assumed: the C compiler must handle assignments of C integers to * C double variables and vice-versa. Hopefully production C compilers * have managed to eliminate bugs related to these assignments. - * - * Note: calls beginning with EV are empty macros unless EventMon - * is defined. */ #define tonum(c) (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a')) @@ -46,15 +43,10 @@ double *d; return 1; } integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) *d = bigtoreal(s); else -#endif /* LargeInts */ - *d = IntVal(*s); - return 1; } string: { @@ -76,15 +68,11 @@ double *d; case T_Integer: *d = numrc.integer; return 1; - -#ifdef LargeInts case T_Lrgint: result.dword = D_Lrgint; BlkLoc(result) = (union block *)numrc.big; *d = bigtoreal(&result); return 1; -#endif /* LargeInts */ - case T_Real: *d = numrc.real; return 1; @@ -106,13 +94,9 @@ C_integer *d; type_case *s of { integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { return 0; } -#endif /* LargeInts */ - *d = IntVal(*s); return 1; } @@ -212,12 +196,8 @@ dptr s, d; register C_integer l; register char *s1; /* does not need to be tended */ - EVValD(s, E_Aconv); - EVValD(&csetdesc, E_Tconv); - if (is:cset(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } /* @@ -232,11 +212,9 @@ dptr s, d; Setb(*s1, *d); s1++; } - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -254,12 +232,9 @@ C_integer *d; type_case *s of { integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { return 0; } -#endif /* LargeInts */ *d = IntVal(*s); return 1; } @@ -321,14 +296,10 @@ dptr s, d; case T_Integer: MakeInt(numrc.integer, d); return 1; - -#ifdef LargeInts case T_Lrgint: d->dword = D_Lrgint; BlkLoc(*d) = (union block *)numrc.big; return 1; -#endif /* LargeInts */ - default: return 0; } @@ -344,36 +315,23 @@ dptr s, d; char sbuf[MaxCvtLen]; union numeric numrc; - EVValD(s, E_Aconv); - EVValD(&zerodesc, E_Tconv); - type_case *s of { integer: { *d = *s; - EVValD(s, E_Nconv); return 1; } real: { double dbl; GetReal(s,dbl); if (dbl > MaxLong || dbl < MinLong) { - -#ifdef LargeInts if (realtobig(s, d) == Succeeded) { - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } -#else /* LargeInts */ - EVValD(s, E_Fconv); - return 0; -#endif /* LargeInts */ } MakeInt((word)dbl,d); - EVValD(d, E_Sconv); return 1; } string: { @@ -384,7 +342,6 @@ dptr s, d; s = &cnvstr; } default: { - EVValD(s, E_Fconv); return 0; } } @@ -393,43 +350,25 @@ dptr s, d; * s is now a string. */ switch( ston(s, &numrc) ) { - -#ifdef LargeInts case T_Lrgint: d->dword = D_Lrgint; BlkLoc(*d) = (union block *)numrc.big; - EVValD(d, E_Sconv); return 1; -#endif /* LargeInts */ - case T_Integer: MakeInt(numrc.integer,d); - EVValD(d, E_Sconv); return 1; case T_Real: { double dbl = numrc.real; if (dbl > MaxLong || dbl < MinLong) { - -#ifdef LargeInts - if (realtobig(s, d) == Succeeded) { - EVValD(d, E_Sconv); + if (realtobig(s, d) == Succeeded) return 1; - } - else { - EVValD(s, E_Fconv); + else return 0; - } -#else /* LargeInts */ - EVValD(s, E_Fconv); - return 0; -#endif /* LargeInts */ - } + } MakeInt((word)dbl,d); - EVValD(d, E_Sconv); return 1; } default: - EVValD(s, E_Fconv); return 0; } } @@ -442,17 +381,12 @@ dptr s, d; { double dbl; - EVValD(s, E_Aconv); - EVValD(&rzerodesc, E_Tconv); - if (cnv_c_dbl(s, &dbl)) { Protect(BlkLoc(*d) = (union block *)alcreal(dbl), fatalerr(0,NULL)); d->dword = D_Real; - EVValD(d, E_Sconv); return 1; } else - EVValD(s, E_Fconv); return 0; } @@ -464,31 +398,23 @@ dptr s, d; { char sbuf[MaxCvtLen]; - EVValD(s, E_Aconv); - EVValD(&emptystr, E_Tconv); - type_case *s of { string: { *d = *s; - EVValD(s, E_Nconv); return 1; } integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { word slen; word dlen; slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1); dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ - bigtos(s,d); - } + bigtos(s,d); + } else -#endif /* LargeInts */ - - itos(IntVal(*s), d, sbuf); - } + itos(IntVal(*s), d, sbuf); + } real: { double res; GetReal(s, res); @@ -497,12 +423,10 @@ dptr s, d; cset: cstos(BlkLoc(*s)->cset.bits, d, sbuf); default: { - EVValD(s, E_Fconv); return 0; } } Protect(StrLoc(*d) = alcstr(StrLoc(*d), StrLen(*d)), fatalerr(0,NULL)); - EVValD(d, E_Sconv); return 1; } @@ -518,12 +442,8 @@ dptr s, d; register char *s1; C_integer l; - EVValD(s, E_Aconv); - EVValD(&csetdesc, E_Tconv); - if (is:cset(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } if (tmp_str(sbuf, s, &tmpstr)) { @@ -537,11 +457,9 @@ dptr s, d; Setb(*s1, *d); s1++; } - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -554,20 +472,14 @@ char *sbuf; dptr s; dptr d; { - EVValD(s, E_Aconv); - EVValD(&emptystr, E_Tconv); - if (is:string(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } else if (tmp_str(sbuf, s, d)) { - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -661,21 +573,17 @@ dptr d; string: *d = *s; integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { word slen; word dlen; slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1); dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ - bigtos(s,d); - } + bigtos(s,d); + } else -#endif /* LargeInts */ - - itos(IntVal(*s), d, sbuf); - } + itos(IntVal(*s), d, sbuf); + } real: { double res; GetReal(s, res); @@ -731,16 +639,10 @@ C_integer arity; /* * See if the string represents a built-in function. */ -#if COMPILER - for (i = 0; i < n_globals; ++i) - if (eq(s, &gnames[i])) - return builtins[i]; /* may be null */ -#else /* COMPILER */ pp = (struct pstrnm *)qsearch((char *)s,(char *)pntab,pnsize, sizeof(struct pstrnm),dp_pnmcmp); if (pp!=NULL) return (struct b_proc *)pp->pblock; -#endif /* !COMPILER */ return NULL; } @@ -887,13 +789,9 @@ union numeric *result; */ if (c == 'r' || c == 'R') { int rv; -#ifdef LargeInts rv = bigradix((int)msign, (int)mantissa, s, end_s, result); if (rv == Error) fatalerr(0, NULL); -#else /* LargeInts */ - rv = radix((int)msign, (int)mantissa, s, end_s, result); -#endif /* LargeInts */ return rv; } @@ -959,21 +857,16 @@ union numeric *result; return T_Integer; } -#ifdef LargeInts /* * Test for bignum. */ -#if COMPILER - if (largeints) -#endif /* COMPILER */ - if (!realflag) { - int rv; - rv = bigradix((int)msign, 10, ssave, end_s, result); - if (rv == Error) - fatalerr(0, NULL); - return rv; - } -#endif /* LargeInts */ + if (!realflag) { + int rv; + rv = bigradix((int)msign, 10, ssave, end_s, result); + if (rv == Error) + fatalerr(0, NULL); + return rv; + } if (!realflag) return CvtFail; /* don't promote to real if integer format */ @@ -1023,50 +916,6 @@ union numeric *result; result->real = mantissa; return T_Real; } - -#if COMPILER || !(defined LargeInts) -/* - * radix - convert string s in radix r into an integer in *result. sign - * will be either '+' or '-'. - */ -int radix(sign, r, s, end_s, result) -int sign; -register int r; -register char *s; -register char *end_s; -union numeric *result; - { - register int c; - long num; - - if (r < 2 || r > 36) - return CvtFail; - c = (s < end_s) ? *s++ : ' '; - num = 0L; - while (isalnum(c)) { - c = tonum(c); - if (c >= r) - return CvtFail; - num = num * r + c; - c = (s < end_s) ? *s++ : ' '; - } - - /* - * Skip trailing white space and make sure there is nothing else left - * in the string. Note, if we have already reached end-of-string, - * c has been set to a space. - */ - while (isspace(c) && s < end_s) - c = *s++; - if (!isspace(c)) - return CvtFail; - - result->integer = (sign == '+' ? num : -num); - - return T_Integer; - } -#endif /* COMPILER || !(defined LargeInts) */ - /* * cvpos - convert position to strictly positive position diff --git a/src/runtime/data.r b/src/runtime/data.r index 1a276bd..be8c169 100644 --- a/src/runtime/data.r +++ b/src/runtime/data.r @@ -2,16 +2,8 @@ * data.r -- Various interpreter data tables. */ -#if !COMPILER - struct b_proc Bnoproc; -#ifdef EventMon -struct b_iproc mt_llist = { - 6, (sizeof(struct b_proc) - sizeof(struct descrip)), Ollist, - 0, -1, 0, 0, {sizeof( "[...]")-1, "[...]"}}; -#endif /* EventMon */ - /* * External declarations for function blocks. @@ -87,7 +79,6 @@ struct pstrnm pntab[] = { int pnsize = (sizeof(pntab) / sizeof(struct pstrnm)) - 1; -#endif /* COMPILER */ /* * Structures for built-in values. Parts of some of these structures are @@ -132,8 +123,6 @@ struct b_cset fullcs = { ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0) }; -#if !COMPILER - /* * Built-in csets */ @@ -181,29 +170,17 @@ struct b_cset k_letters = { cset_display(0, 0, 0, 0, ~01, 03777, ~01, 03777, 0, 0, 0, 0, 0, 0, 0, 0) }; -#endif /* COMPILER */ /* * Built-in files. */ - -#ifndef MultiThread struct b_file k_errout = {T_File, NULL, Fs_Write}; /* &errout */ struct b_file k_input = {T_File, NULL, Fs_Read}; /* &input */ struct b_file k_output = {T_File, NULL, Fs_Write}; /* &output */ -#endif /* MultiThread */ - -#ifdef EventMon -/* - * Real block needed for event monitoring. - */ -struct b_real realzero = {T_Real, 0.0}; -#endif /* EventMon */ /* * Keyword variables. */ -#ifndef MultiThread struct descrip kywd_err = {D_Integer}; /* &error */ struct descrip kywd_pos = {D_Integer}; /* &pos */ struct descrip kywd_prog; /* &progname */ @@ -213,13 +190,6 @@ struct descrip kywd_trc = {D_Integer}; /* &trace */ struct descrip k_eventcode = {D_Null}; /* &eventcode */ struct descrip k_eventsource = {D_Null};/* &eventsource */ struct descrip k_eventvalue = {D_Null}; /* &eventvalue */ - -#endif /* MultiThread */ - -#ifdef FncTrace -struct descrip kywd_ftrc = {D_Integer}; /* &ftrace */ -#endif /* FncTrace */ - struct descrip kywd_dmp = {D_Integer}; /* &dump */ struct descrip nullptr = @@ -239,15 +209,6 @@ struct descrip onedesc = {D_Integer}; /* integer 1 */ struct descrip ucase; /* string of uppercase letters */ struct descrip zerodesc = {D_Integer}; /* integer 0 */ -#ifdef EventMon -/* - * Descriptors used by event monitoring. - */ -struct descrip csetdesc = {D_Cset}; -struct descrip eventdesc; -struct descrip rzerodesc = {D_Real}; -#endif /* EventMon */ - /* * An array of all characters for use in making one-character strings. */ @@ -303,6 +264,12 @@ struct errtab errtab[] = { 125, "list, record, or set expected", 126, "list or record expected", + /* general messages for use by code dealing with external data */ + 131, "external expected", /* not an external */ + 132, "incorrect external type", /* external of wrong flavor */ + 133, "invalid external value", /* right flavor in wrong context */ + 134, "malformed external value", /* data bogus, not just inappropriate */ + #ifdef Graphics 140, "window expected", 141, "program terminated by window manager", @@ -344,9 +311,6 @@ struct errtab errtab[] = { 307, "inadequate space in block region", 308, "system stack overflow in co-expression", -#ifndef Coexpr - 401, "co-expressions not implemented", -#endif /* Coexpr */ 402, "program not compiled with debugging option", 500, "program malfunction", /* for use by runerr() */ @@ -355,7 +319,6 @@ struct errtab errtab[] = { 0, "" }; -#if !COMPILER #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); #include "../h/odefs.h" #undef OpDef @@ -398,4 +361,3 @@ int (*keytab[])() = { #define KDef(p,n) Cat(K,p), #include "../h/kdefs.h" }; -#endif /* !COMPILER */ diff --git a/src/runtime/errmsg.r b/src/runtime/errmsg.r index 7095781..03d558a 100644 --- a/src/runtime/errmsg.r +++ b/src/runtime/errmsg.r @@ -38,18 +38,11 @@ dptr v; break; } - EVVal((word)k_errornumber,E_Error); - if (pfp != NULL) { if (IntVal(kywd_err) == 0 || !err_conv) { fprintf(stderr, "\nRun-time error %d\n", k_errornumber); -#if COMPILER - if (line_info) - fprintf(stderr, "File %s; Line %d\n", file_name, line_num); -#else /* COMPILER */ fprintf(stderr, "File %s; Line %ld\n", findfile(ipc.opnd), (long)findline(ipc.opnd)); -#endif /* COMPILER */ } else { IntVal(kywd_err)--; diff --git a/src/runtime/extcall.r b/src/runtime/extcall.r deleted file mode 100644 index 5652416..0000000 --- a/src/runtime/extcall.r +++ /dev/null @@ -1,21 +0,0 @@ -/* - * extcall.r - */ - -#if !COMPILER -#ifdef ExternalFunctions - -/* - * extcall - stub procedure for external call interface. - */ -dptr extcall(dargv, argc, ip) -dptr dargv; -int argc; -int *ip; - { - *ip = 216; /* no external function to find */ - return (dptr)NULL; - } - -#endif /* ExternalFunctions */ -#endif /* !COMPILER */ diff --git a/src/runtime/fconv.r b/src/runtime/fconv.r index 7c3a3ff..d458062 100644 --- a/src/runtime/fconv.r +++ b/src/runtime/fconv.r @@ -22,24 +22,17 @@ function{1} abs(n) else { i = neg(n); if (over_flow) { -#ifdef LargeInts struct descrip tmp; MakeInt(n,&tmp); if (bigneg(&tmp, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - irunerr(203,n); - errorfail; -#endif /* LargeInts */ } } return C_integer i; } } - -#ifdef LargeInts else if cnv:(exact)integer(n) then { abstract { return integer @@ -54,7 +47,6 @@ function{1} abs(n) return result; } } -#endif /* LargeInts */ else if cnv:C_double(n) then { abstract { @@ -140,55 +132,13 @@ end "proc(x,i) - convert x to a procedure if possible; use i to resolve " "ambiguous string names." -#ifdef MultiThread -function{0,1} proc(x,i,c) -#else /* MultiThread */ function{0,1} proc(x,i) -#endif /* MultiThread */ - -#ifdef MultiThread - if is:coexpr(x) then { - abstract { - return proc - } - inline { - struct b_coexpr *ce = NULL; - struct b_proc *bp = NULL; - struct pf_marker *fp; - dptr dp=NULL; - if (BlkLoc(x) != BlkLoc(k_current)) { - ce = (struct b_coexpr *)BlkLoc(x); - dp = ce->es_argp; - if (dp == NULL) fail; - bp = (struct b_proc *)BlkLoc(*(dp)); - } - else - bp = (struct b_proc *)BlkLoc(*(glbl_argp)); - return proc(bp); - } - } -#endif /* MultiThread */ if is:proc(x) then { abstract { return proc } inline { - -#ifdef MultiThread - if (!is:null(c)) { - struct progstate *p; - if (!is:coexpr(c)) runerr(118,c); - /* - * Test to see whether a given procedure belongs to a given - * program. Currently this is a sleazy pointer arithmetic check. - */ - p = BlkLoc(c)->coexpr.program; - if (! InRange(p, BlkLoc(x)->proc.entryp.icode, - (char *)p + p->hsize)) - fail; - } -#endif /* MultiThread */ return x; } } @@ -212,23 +162,6 @@ function{0,1} proc(x,i) inline { struct b_proc *prc; -#ifdef MultiThread - struct progstate *prog, *savedprog; - - savedprog = curpstate; - if (is:null(c)) { - prog = curpstate; - } - else if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - } - else { - runerr(118,c); - } - - ENTERPSTATE(prog); -#endif /* MultiThread */ - /* * Attempt to convert Arg0 to a procedure descriptor using i to * discriminate between procedures with the same names. If i @@ -240,9 +173,6 @@ function{0,1} proc(x,i) else prc = strprc(&x, i); -#ifdef MultiThread - ENTERPSTATE(savedprog); -#endif /* MultiThread */ if (prc == NULL) fail; else diff --git a/src/runtime/fload.r b/src/runtime/fload.r index dfb9fcc..e972002 100644 --- a/src/runtime/fload.r +++ b/src/runtime/fload.r @@ -22,24 +22,6 @@ #define RTLD_LAZY 1 #endif /* RTLD_LAZY */ -#ifdef FreeBSD - /* - * If DL_GETERRNO exists, this is an FreeBSD 1.1.5 or 2.0 - * which lacks dlerror(); supply a substitute. - */ - #passthru #ifdef DL_GETERRNO - char *dlerror(void) - { - int no; - - if (0 == dlctl(NULL, DL_GETERRNO, &no)) - return(strerror(no)); - else - return(NULL); - } - #passthru #endif -#endif /* __FreeBSD__ */ - int glue(); int makefunc (dptr d, char *name, int (*func)()); @@ -69,7 +51,7 @@ function{0,1} loadfunc(filename,funcname) if (curfile) free((pointer)curfile); /* free the old file name */ curfile = salloc(filename); /* save the new name */ - handle = dlopen(filename, RTLD_LAZY); /* get the handle */ + handle = dlopen(filename, RTLD_LAZY | RTLD_GLOBAL); /* get handle */ } /* * Load the function. Diagnose both library and function errors here. @@ -121,12 +103,7 @@ int (*func)(); return 0; blk->title = T_Proc; blk->blksize = sizeof(struct b_proc); - -#if COMPILER - blk->ccode = glue; /* set code addr to glue routine */ -#else /* COMPILER */ blk->entryp.ccode = glue; /* set code addr to glue routine */ -#endif /* COMPILER */ blk->nparam = -1; /* varargs flag */ blk->ndynam = -1; /* treat as built-in function */ @@ -147,47 +124,6 @@ int (*func)(); * It digs the actual C code address out of the proc block, and calls that. */ -#if COMPILER - -int glue(argc, dargv, rslt, succ_cont) -int argc; -dptr dargv; -dptr rslt; -continuation succ_cont; - { - int i, status, (*func)(); - struct b_proc *blk; - struct descrip r; - tended struct descrip p; - - dargv--; /* reset pointer to proc entry */ - for (i = 0; i <= argc; i++) - deref(&dargv[i], &dargv[i]); /* dereference args including proc */ - - blk = (struct b_proc *)dargv[0].vword.bptr; /* proc block address */ - func = (int (*)())blk->lnames[0].vword.sptr; /* entry point address */ - - p = dargv[0]; /* save proc for traceback */ - dargv[0] = nulldesc; /* set default return value */ - status = (*func)(argc, dargv); /* call func */ - - if (status == 0) { - *rslt = dargv[0]; - Return; /* success */ - } - - if (status < 0) - Fail; /* failure */ - - r = dargv[0]; /* save result value */ - dargv[0] = p; /* restore proc for traceback */ - if (is:null(r)) - RunErr(status, NULL); /* error, no value */ - RunErr(status, &r); /* error, with value */ - } - -#else /* COMPILER */ - int glue(argc, dargv) int argc; dptr dargv; @@ -216,6 +152,4 @@ dptr dargv; RunErr(status, &r); /* error, with value */ } -#endif /* COMPILER */ - #endif /* LoadFunc */ diff --git a/src/runtime/fmisc.r b/src/runtime/fmisc.r index 6691241..2c4474d 100644 --- a/src/runtime/fmisc.r +++ b/src/runtime/fmisc.r @@ -5,9 +5,7 @@ * ishift, ixor, [keyword], [load], ord, name, runerr, seq, sort, sortf, * type, variable */ -#if !COMPILER #include "../h/opdefs.h" -#endif /* !COMPILER */ "args(p) - produce number of arguments for procedure p." @@ -24,53 +22,6 @@ function{1} args(x) } end -#if !COMPILER -#ifdef ExternalFunctions - -/* - * callout - call a C library routine (or any C routine that doesn't call Icon) - * with an argument count and a list of descriptors. This routine - * doesn't build a procedure frame to prepare for calling Icon back. - */ -function{1} callout(x[nargs]) - body { - dptr retval; - int signal; - - /* - * Little cheat here. Although this is a var-arg procedure, we need - * at least one argument to get started: pretend there is a null on - * the stack. NOTE: Actually, at present, varargs functions always - * have at least one argument, so this doesn't plug the hole. - */ - if (nargs < 1) - runerr(103, nulldesc); - - /* - * Call the 'C routine caller' with a pointer to an array of descriptors. - * Note that these are being left on the stack. We are passing - * the name of the routine as part of the convention of calling - * routines with an argc/argv technique. - */ - signal = -1; /* presume successful completiong */ - retval = extcall(x, nargs, &signal); - if (signal >= 0) { - if (retval == NULL) - runerr(signal); - else - runerr(signal, *retval); - } - if (retval != NULL) { - return *retval; - } - else - fail; - } -end - -#endif /* ExternalFunctions */ -#endif /* !COMPILER */ - "char(i) - produce a string consisting of character i." @@ -174,11 +125,6 @@ function{1} copy(x) } table: { body { -#ifdef TableFix - if (cptable(&x, &result, BlkLoc(x)->table.size) == Error) - runerr(0); - return result; -#else /* TableFix */ register int i; register word slotnum; tended union block *src; @@ -195,7 +141,10 @@ function{1} copy(x) runerr(0); dst->table.size = src->table.size; dst->table.mask = src->table.mask; - dst->table.defvalue = src->table.defvalue; + /* dst->table.defvalue = src->table.defvalue; */ + /* to avoid gcc 4.2.2 bug on Sparc, do instead: */ + memcpy(&dst->table.defvalue, &src->table.defvalue, + sizeof(struct descrip)); for (i = 0; i < HSegs && src->table.hdir[i] != NULL; i++) memcpy((char *)dst->table.hdir[i], (char *)src->table.hdir[i], src->table.hdir[i]->blksize); @@ -221,9 +170,7 @@ function{1} copy(x) if (TooSparse(dst)) hshrink(dst); - Desc_EVValD(dst, E_Tcreate, D_Table); return table(dst); -#endif /* TableFix */ } } @@ -262,14 +209,17 @@ function{1} copy(x) d2 = old_rec->fields; while (i--) *d1++ = *d2++; - Desc_EVValD(new_rec, E_Rcreate, D_Record); return record(new_rec); } } - default: body { - runerr(123,x); - } + default: + body { + if (Type(x) == T_External) + return callextfunc(&extlcopy, &x, NULL); + else + runerr(123,x); + } } end @@ -278,15 +228,7 @@ end " procedure activations, plus global variables." " Output to file f (default &errout)." -#ifdef MultiThread -function{1} display(i,f,c) - declare { - struct b_coexpr *ce = NULL; - struct progstate *prog, *savedprog; - } -#else /* MultiThread */ function{1} display(i,f) -#endif /* MultiThread */ if !def:C_integer(i,(C_integer)k_level) then runerr(101, i) @@ -299,15 +241,6 @@ function{1} display(i,f) else if !is:file(f) then runerr(105, f) -#ifdef MultiThread - if !is:null(c) then inline { - if (!is:coexpr(c)) runerr(118,c); - else if (BlkLoc(c) != BlkLoc(k_current)) - ce = (struct b_coexpr *)BlkLoc(c); - savedprog = curpstate; - } -#endif /* MultiThread */ - abstract { return null } @@ -340,16 +273,7 @@ function{1} display(i,f) (long)BlkLoc(k_current)->coexpr.id, (long)BlkLoc(k_current)->coexpr.size); fflush(std_f); -#ifdef MultiThread - if (ce) { - if ((ce->es_pfp == NULL) || (ce->es_argp == NULL)) fail; - ENTERPSTATE(ce->program); - r = xdisp(ce->es_pfp, ce->es_argp, (int)i, std_f); - ENTERPSTATE(savedprog); - } - else -#endif /* MultiThread */ - r = xdisp(pfp, glbl_argp, (int)i, std_f); + r = xdisp(pfp, glbl_argp, (int)i, std_f); if (r == Failed) runerr(305); return nulldesc; @@ -372,7 +296,6 @@ function{1} errorclear() } end -#if !COMPILER "function() - generate the names of the functions." @@ -389,7 +312,6 @@ function{*} function() fail; } end -#endif /* !COMPILER */ /* @@ -412,13 +334,11 @@ function{1} func_name(i,j) return integer } inline { -#ifdef LargeInts if ((Type(i)==T_Lrgint) || (Type(j)==T_Lrgint)) { big_ ## c_op(i,j); } else -#endif /* LargeInts */ - return C_integer IntVal(i) c_op IntVal(j); + return C_integer IntVal(i) c_op IntVal(j); } end #enddef @@ -466,7 +386,6 @@ function{1} icom(i) return integer } inline { -#ifdef LargeInts if (Type(i) == T_Lrgint) { struct descrip td; @@ -477,8 +396,7 @@ function{1} icom(i) return result; } else -#endif /* LargeInts */ - return C_integer ~IntVal(i); + return C_integer ~IntVal(i); } end @@ -514,7 +432,6 @@ function{1} ishift(i,j) body { uword ci; /* shift in 0s, even if negative */ C_integer cj; -#ifdef LargeInts if (Type(j) == T_Lrgint) runerr(101,j); cj = IntVal(j); @@ -524,10 +441,6 @@ function{1} ishift(i,j) runerr(0); return result; } -#else /* LargeInts */ - ci = (uword)IntVal(i); - cj = IntVal(j); -#endif /* LargeInts */ /* * Check for a shift of WordSize or greater; handle specially because * this is beyond C's defined behavior. Otherwise shift as requested. @@ -564,14 +477,7 @@ end "name(v) - return the name of a variable." -#ifdef MultiThread -function{1} name(underef v, c) - declare { - struct progstate *prog, *savedprog; - } -#else /* MultiThread */ function{1} name(underef v) -#endif /* MultiThread */ /* * v must be a variable */ @@ -586,27 +492,7 @@ function{1} name(underef v) C_integer i; if (!debug_info) runerr(402); - -#ifdef MultiThread - savedprog = curpstate; - if (is:null(c)) { - prog = curpstate; - } - else if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - } - else { - runerr(118,c); - } - - ENTERPSTATE(prog); -#endif /* MultiThread */ i = get_name(&v, &result); /* return val ? #%#% */ - -#ifdef MultiThread - ENTERPSTATE(savedprog); -#endif /* MultiThread */ - if (i == Error) runerr(0); return result; @@ -672,7 +558,6 @@ function{1,*} seq(from, by) } while (from >= seq_lb && from <= seq_ub); -#if !COMPILER { /* * Suspending wipes out some things needed by the trace back code to @@ -684,7 +569,6 @@ function{1,*} seq(from, by) r_args[0].dword = D_Proc; r_args[0].vword.bptr = (union block *)&Bseq; } -#endif /* COMPILER */ runerr(203); } @@ -724,8 +608,12 @@ function {0,1} serial(x) } } #endif /* Graphics */ - default: - inline { fail; } + default: inline { + if (Type(x) == T_External) + return C_integer BlkLoc(x)->externl.id; + else + fail; + } } end @@ -750,7 +638,6 @@ function{1} sort(t, i) qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots, (int)size, sizeof(struct descrip), (int (*)()) anycmp); - Desc_EVValD(BlkLoc(result), E_Lcreate, D_List); return result; } } @@ -775,9 +662,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty records */ @@ -788,7 +672,6 @@ function{1} sort(t, i) sizeof(struct descrip), (int (*)())anycmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -814,9 +697,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty sets */ @@ -829,7 +709,6 @@ function{1} sort(t, i) sizeof(struct descrip), (int (*)())anycmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -883,9 +762,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep=(union block *)alclstb(size,(word)0,size),runerr(0)); lp->listtail = lp->listhead = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ /* * If the table is empty, there is no need to sort anything. */ @@ -904,20 +780,12 @@ function{1} sort(t, i) for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++) for (k = segsize[j] - 1; k >= 0; k--) for (ep= seg->hslots[k]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink){ Protect(tp = alclist((word)2), runerr(0)); Protect(ev = (union block *)alclstb((word)2, (word)0, (word)2), runerr(0)); tp->listhead = tp->listtail = ev; -#ifdef ListFix - ev->lelem.listprev = ev->lelem.listnext = - (union block *)tp; -#endif /* ListFix */ tp->listhead->lelem.lslots[0] = ep->telem.tref; tp->listhead->lelem.lslots[1] = ep->telem.tval; d1 = &lp->listhead->lelem.lslots[n++]; @@ -958,9 +826,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ /* * If the table is empty there's no need to sort anything. */ @@ -983,11 +848,7 @@ function{1} sort(t, i) for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++) for (k = segsize[j] - 1; k >= 0; k--) for (ep = seg->hslots[k]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink) { *d1++ = ep->telem.tref; *d1++ = ep->telem.tval; @@ -1016,7 +877,6 @@ function{1} sort(t, i) * Make result point at the sorted list. */ - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1033,12 +893,6 @@ end int trefcmp(d1,d2) dptr d1, d2; { - -#ifdef DeBug - if (d1->dword != D_List || d2->dword != D_List) - syserr("trefcmp: internal consistency check fails."); -#endif /* DeBug */ - return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[0]))); } @@ -1050,12 +904,6 @@ dptr d1, d2; int tvalcmp(d1,d2) dptr d1, d2; { - -#ifdef DeBug - if (d1->dword != D_List || d2->dword != D_List) - syserr("tvalcmp: internal consistency check fails."); -#endif /* DeBug */ - return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[1]))); } @@ -1113,7 +961,6 @@ function{1} sortf(t, i) qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots, (int)size, sizeof(struct descrip), (int (*)()) nthcmp); - Desc_EVValD(BlkLoc(result), E_Lcreate, D_List); return result; } } @@ -1146,9 +993,6 @@ function{1} sortf(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty records */ @@ -1160,7 +1004,6 @@ function{1} sortf(t, i) sizeof(struct descrip), (int (*)())nthcmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1194,9 +1037,6 @@ function{1} sortf(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty sets */ @@ -1210,7 +1050,6 @@ function{1} sortf(t, i) sizeof(struct descrip), (int (*)())nthcmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1337,12 +1176,9 @@ function{1} type(x) coexpr: inline { return C_string "co-expression"; } default: inline { -#if !COMPILER - if (!Qual(x) && (Type(x)==T_External)) { - return C_string "external"; - } + if (!Qual(x) && (Type(x) == T_External)) + return callextfunc(&extlname, &x, NULL); else -#endif /* !COMPILER */ runerr(123,x); } } @@ -1352,853 +1188,20 @@ end "variable(s) - find the variable with name s and return a" " variable descriptor which points to its value." -#ifdef MultiThread -function{0,1} variable(s,c,i) -#else /* MultiThread */ function{0,1} variable(s) -#endif /* MultiThread */ - if !cnv:C_string(s) then runerr(103, s) -#ifdef MultiThread - if !def:C_integer(i,0) then - runerr(101,i) -#endif /* MultiThread */ - abstract { return variable } body { register int rv; - -#ifdef MultiThread - struct progstate *prog, *savedprog; - struct pf_marker *tmp_pfp = pfp; - dptr tmp_argp = glbl_argp; - - savedprog = curpstate; - if (!is:null(c)) { - if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - pfp = BlkLoc(c)->coexpr.es_pfp; - glbl_argp = BlkLoc(c)->coexpr.es_argp; - ENTERPSTATE(prog); - } - else { - runerr(118, c); - } - } - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - if (pfp == NULL) fail; - glbl_argp = pfp->pf_argp; - pfp = pfp->pf_pfp; - } -#endif /* MultiThread */ - rv = getvar(s, &result); - -#ifdef MultiThread - if (is:coexpr(c)) { - ENTERPSTATE(savedprog); - pfp = tmp_pfp; - glbl_argp = tmp_argp; - - if ((rv == LocalName) || (rv == StaticName)) { - Deref(result); - } - } -#endif /* MultiThread */ - if (rv != Failed) return result; else fail; } end - -#ifdef MultiThread - -"cofail(CE) - transmit a co-expression failure to CE" - -function{0,1} cofail(CE) - abstract { - return any_value - } - if is:null(CE) then - body { - struct b_coexpr *ce = topact((struct b_coexpr *)BlkLoc(k_current)); - if (ce != NULL) { - CE.dword = D_Coexpr; - BlkLoc(CE) = (union block *)ce; - } - else runerr(118,CE); - } - else if !is:coexpr(CE) then - runerr(118,CE) - body { - struct b_coexpr *ncp = (struct b_coexpr *)BlkLoc(CE); - if (co_chng(ncp, NULL, &result, A_Cofail, 1) == A_Cofail) fail; - return result; - } -end - - -"fieldnames(r) - generate the fieldnames of record r" - -function{*} fieldnames(r) - abstract { - return string - } - if !is:record(r) then runerr(107,r) - body { - int i; - for(i=0;i<BlkLoc(r)->record.recdesc->proc.nfields;i++) { - suspend BlkLoc(r)->record.recdesc->proc.lnames[i]; - } - fail; - } -end - - -"localnames(ce,i) - produce the names of local variables" -" in the procedure activation i levels up in ce" -function{*} localnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->ndynam; j++) { - result = cproc->lnames[j + cproc->nparam]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118, ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j = 0; j < cproc->ndynam; j++) { - result = cproc->lnames[j + cproc->nparam]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - - - -"staticnames(ce,i) - produce the names of static variables" -" in the current procedure activation in ce" - -function{*} staticnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->nstatic; j++) { - result = cproc->lnames[j + cproc->nparam + cproc->ndynam]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118,ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j=0; j < cproc->nstatic; j++) { - result = cproc->lnames[j + cproc->nparam + cproc->ndynam]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - -"paramnames(ce,i) - produce the names of the parameters" -" in the current procedure activation in ce" - -function{1,*} paramnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_main; - BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->nparam; j++) { - result = cproc->lnames[j]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118,ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j = 0; j < cproc->nparam; j++) { - result = cproc->lnames[j]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - - -"load(s,arglist,input,output,error,blocksize,stringsize,stacksize) - load" -" an icode file corresponding to string s as a co-expression." - -function{1} load(s,arglist,infile,outfile,errfile, - blocksize, stringsize, stacksize) - declare { - tended char *loadstring; - C_integer _bs_, _ss_, _stk_; - } - if !cnv:C_string(s,loadstring) then - runerr(103,s) - if !def:C_integer(blocksize,abrsize,_bs_) then - runerr(101,blocksize) - if !def:C_integer(stringsize,ssize,_ss_) then - runerr(101,stringsize) - if !def:C_integer(stacksize,mstksize,_stk_) then - runerr(101,stacksize) - abstract { - return coexpr - } - body { - word *stack; - struct progstate *pstate; - char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; - register struct b_coexpr *sblkp; - register struct b_refresh *rblkp; - struct ef_marker *newefp; - register dptr dp, ndp, dsp; - register word *newsp, *savedsp; - int na, nl, i, j, num_fileargs = 0; - struct b_file *theInput = NULL, *theOutput = NULL, *theError = NULL; - struct b_proc *cproc; - extern char *prog_name; - - /* - * Fragments of pseudo-icode to get loaded programs started, - * and to handle termination. - */ - static word pstart[7]; - static word *lterm; - - inst tipc; - - tipc.opnd = pstart; - *tipc.op++ = Op_Noop; /* aligns Invokes operand */ /* ?cj? */ - *tipc.op++ = Op_Invoke; - *tipc.opnd++ = 1; - *tipc.op++ = Op_Coret; - *tipc.op++ = Op_Efail; - - lterm = (word *)(tipc.op); - - *tipc.op++ = Op_Cofail; - *tipc.op++ = Op_Agoto; - *tipc.opnd = (word)lterm; - - prog_name = loadstring; /* set up for &progname */ - - /* - * arglist must be a list - */ - if (!is:null(arglist) && !is:list(arglist)) - runerr(108,arglist); - - /* - * input, output, and error must be files - */ - if (is:null(infile)) - theInput = &(curpstate->K_input); - else { - if (!is:file(infile)) - runerr(105,infile); - else theInput = &(BlkLoc(infile)->file); - } - if (is:null(outfile)) - theOutput = &(curpstate->K_output); - else { - if (!is:file(outfile)) - runerr(105,outfile); - else theOutput = &(BlkLoc(outfile)->file); - } - if (is:null(errfile)) - theError = &(curpstate->K_errout); - else { - if (!is:file(errfile)) - runerr(105,errfile); - else theError = &(BlkLoc(errfile)->file); - } - - stack = - (word *)(sblkp = loadicode(loadstring,theInput,theOutput,theError, - _bs_,_ss_,_stk_)); - if(!stack) { - fail; - } - pstate = sblkp->program; - pstate->parent = curpstate; - pstate->parentdesc = k_main; - - savedsp = sp; - sp = stack + Wsizeof(struct b_coexpr) - + Wsizeof(struct progstate) + pstate->hsize/WordSize; - if (pstate->hsize % WordSize) sp++; - -#ifdef UpStack - sblkp->cstate[0] = - ((word)((char *)sblkp + (mstksize - (sizeof(*sblkp)+sizeof(struct progstate)+pstate->hsize))/2) - &~((word)WordSize*StackAlign-1)); -#else /* UpStack */ - sblkp->cstate[0] = - ((word)((char *)sblkp + mstksize - WordSize + sizeof(struct progstate) + pstate->hsize) - &~((word)WordSize*StackAlign-1)); -#endif /* UpStack */ - - sblkp->es_argp = NULL; - sblkp->es_gfp = NULL; - pstate->Mainhead->freshblk = nulldesc;/* &main has no refresh block. */ - /* This really is a bug. */ - - /* - * Set up expression frame marker to contain execution of the - * main procedure. If failure occurs in this context, control - * is transferred to lterm, the address of an ... - */ - newefp = (struct ef_marker *)(sp+1); -#if IntBits != WordBits - newefp->ef_failure.op = (int *)lterm; -#else /* IntBits != WordBits */ - newefp->ef_failure.op = lterm; -#endif /* IntBits != WordBits */ - - newefp->ef_gfp = 0; - newefp->ef_efp = 0; - newefp->ef_ilevel = ilevel/*1*/; - sp += Wsizeof(*newefp) - 1; - sblkp->es_efp = newefp; - - /* - * The first global variable holds the value of "main". If it - * is not of type procedure, this is noted as run-time error 117. - * Otherwise, this value is pushed on the stack. - */ - if (pstate->Globals[0].dword != D_Proc) - fatalerr(117, NULL); - - PushDesc(pstate->Globals[0]); - - /* - * Create a list from arguments using Ollist and push a descriptor - * onto new stack. Then create procedure frame on new stack. Push - * two new null descriptors, and set sblkp->es_sp when all finished. - */ - if (!is:null(arglist)) { - PushDesc(arglist); - pstate->Glbl_argp = (dptr)(sp - 1); - } - else { - PushNull; - pstate->Glbl_argp = (dptr)(sp - 1); - { - dptr tmpargp = (dptr) (sp - 1); - Ollist(0, tmpargp); - sp = (word *)tmpargp + 1; - } - } - sblkp->es_sp = (word *)sp; - sblkp->es_ipc.opnd = pstart; - - result.dword = D_Coexpr; - BlkLoc(result) = (union block *)sblkp; - sp = savedsp; - return result; - } -end - - -"parent(ce) - given a ce, return &main for that ce's parent" - -function{1} parent(ce) - if is:null(ce) then inline { ce = k_current; } - else if !is:coexpr(ce) then runerr(118,ce) - abstract { - return coexpr - } - body { - if (BlkLoc(ce)->coexpr.program->parent == NULL) fail; - - result.dword = D_Coexpr; - BlkLoc(result) = - (union block *)(BlkLoc(ce)->coexpr.program->parent->Mainhead); - return result; - } -end - -#ifdef EventMon - -"eventmask(ce,cs) - given a ce, get or set that program's event mask" - -function{1} eventmask(ce,cs) - if !is:coexpr(ce) then runerr(118,ce) - - if is:null(cs) then { - abstract { - return cset++null - } - body { - result = BlkLoc(ce)->coexpr.program->eventmask; - return result; - } - } - else if !cnv:cset(cs) then runerr(104,cs) - else { - abstract { - return cset - } - body { - ((struct b_coexpr *)BlkLoc(ce))->program->eventmask = cs; - return cs; - } - } -end -#endif /* EventMon */ - - -"globalnames(ce) - produce the names of identifiers global to ce" - -function{*} globalnames(ce) - declare { - struct progstate *ps; - } - abstract { - return string - } - if is:null(ce) then inline { ps = curpstate; } - else if is:coexpr(ce) then - inline { ps = BlkLoc(ce)->coexpr.program; } - else runerr(118,ce) - body { - struct descrip *dp; - for (dp = ps->Gnames; dp != ps->Egnames; dp++) { - suspend *dp; - } - fail; - } -end - -"keyword(kname,ce) - produce a keyword in ce's thread" -function{*} keyword(keyname,ce) - declare { - tended struct descrip d; - tended char *kyname; - } - abstract { - return any_value - } - if !cnv:C_string(keyname,kyname) then runerr(103,keyname) - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - BlkLoc(k_current)->coexpr.es_ipc.opnd = ipc.opnd; - } - else if is:coexpr(ce) then - inline { d = ce; } - else runerr(118, ce) - body { - struct progstate *p = BlkLoc(d)->coexpr.program; - char *kname = kyname; - if (kname[0] == '&') kname++; - if (strcmp(kname,"allocated") == 0) { - suspend C_integer stattotal + p->stringtotal + p->blocktotal; - suspend C_integer stattotal; - suspend C_integer p->stringtotal; - return C_integer p->blocktotal; - } - else if (strcmp(kname,"collections") == 0) { - suspend C_integer p->colltot; - suspend C_integer p->collstat; - suspend C_integer p->collstr; - return C_integer p->collblk; - } - else if (strcmp(kname,"column") == 0) { - struct progstate *savedp = curpstate; - int i; - ENTERPSTATE(p); - i = findcol(BlkLoc(d)->coexpr.es_ipc.opnd); - ENTERPSTATE(savedp); - return C_integer i; - } - else if (strcmp(kname,"current") == 0) { - return p->K_current; - } - else if (strcmp(kname,"error") == 0) { - return kywdint(&(p->Kywd_err)); - } - else if (strcmp(kname,"errornumber") == 0) { - return C_integer p->K_errornumber; - } - else if (strcmp(kname,"errortext") == 0) { - return C_string p->K_errortext; - } - else if (strcmp(kname,"errorvalue") == 0) { - return p->K_errorvalue; - } - else if (strcmp(kname,"errout") == 0) { - return file(&(p->K_errout)); - } - else if (strcmp(kname,"eventcode") == 0) { - return kywdevent(&(p->eventcode)); - } - else if (strcmp(kname,"eventsource") == 0) { - return kywdevent(&(p->eventsource)); - } - else if (strcmp(kname,"eventvalue") == 0) { - return kywdevent(&(p->eventval)); - } - else if (strcmp(kname,"file") == 0) { - struct progstate *savedp = curpstate; - struct descrip s; - ENTERPSTATE(p); - StrLoc(s) = findfile(BlkLoc(d)->coexpr.es_ipc.opnd); - StrLen(s) = strlen(StrLoc(s)); - ENTERPSTATE(savedp); - if (!strcmp(StrLoc(s),"?")) fail; - return s; - } - else if (strcmp(kname,"input") == 0) { - return file(&(p->K_input)); - } - else if (strcmp(kname,"level") == 0) { - /* - * Bug; levels aren't maintained per program yet. - * But shouldn't they be per co-expression, not per program? - */ - } - else if (strcmp(kname,"line") == 0) { - struct progstate *savedp = curpstate; - int i; - ENTERPSTATE(p); - i = findline(BlkLoc(d)->coexpr.es_ipc.opnd); - ENTERPSTATE(savedp); - return C_integer i; - } - else if (strcmp(kname,"main") == 0) { - return p->K_main; - } - else if (strcmp(kname,"output") == 0) { - return file(&(p->K_output)); - } - else if (strcmp(kname,"pos") == 0) { - return kywdpos(&(p->Kywd_pos)); - } - else if (strcmp(kname,"progname") == 0) { - return kywdstr(&(p->Kywd_prog)); - } - else if (strcmp(kname,"random") == 0) { - return kywdint(&(p->Kywd_ran)); - } - else if (strcmp(kname,"regions") == 0) { - word allRegions = 0; - struct region *rp; - - suspend C_integer 0; - for (rp = p->stringregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->end,rp->base); - for (rp = p->stringregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->end,rp->base); - suspend C_integer allRegions; - - allRegions = 0; - for (rp = p->blockregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->end,rp->base); - for (rp = p->blockregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->end,rp->base); - return C_integer allRegions; - } - else if (strcmp(kname,"source") == 0) { - return coexpr(topact((struct b_coexpr *)BlkLoc(BlkLoc(d)->coexpr.program->K_current))); -/* - if (BlkLoc(d)->coexpr.es_actstk) - return coexpr(topact((struct b_coexpr *)BlkLoc(d))); - else return BlkLoc(d)->coexpr.program->parent->K_main; -*/ - } - else if (strcmp(kname,"storage") == 0) { - word allRegions = 0; - struct region *rp; - suspend C_integer 0; - for (rp = p->stringregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->free,rp->base); - for (rp = p->stringregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->free,rp->base); - suspend C_integer allRegions; - - allRegions = 0; - for (rp = p->blockregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->free,rp->base); - for (rp = p->blockregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->free,rp->base); - return C_integer allRegions; - } - else if (strcmp(kname,"subject") == 0) { - return kywdsubj(&(p->ksub)); - } - else if (strcmp(kname,"trace") == 0) { - return kywdint(&(p->Kywd_trc)); - } -#ifdef Graphics - else if (strcmp(kname,"window") == 0) { - return kywdwin(&(p->Kywd_xwin[XKey_Window])); - } - else if (strcmp(kname,"col") == 0) { - return kywdint(&(p->AmperCol)); - } - else if (strcmp(kname,"row") == 0) { - return kywdint(&(p->AmperRow)); - } - else if (strcmp(kname,"x") == 0) { - return kywdint(&(p->AmperX)); - } - else if (strcmp(kname,"y") == 0) { - return kywdint(&(p->AmperY)); - } - else if (strcmp(kname,"interval") == 0) { - return kywdint(&(p->AmperInterval)); - } - else if (strcmp(kname,"control") == 0) { - if (p->Xmod_Control) - return nulldesc; - else - fail; - } - else if (strcmp(kname,"shift") == 0) { - if (p->Xmod_Shift) - return nulldesc; - else - fail; - } - else if (strcmp(kname,"meta") == 0) { - if (p->Xmod_Meta) - return nulldesc; - else - fail; - } -#endif /* Graphics */ - runerr(205, keyname); - } -end -#ifdef EventMon - -"opmask(ce,cs) - get or set ce's program's opcode mask" - -function{1} opmask(ce,cs) - if !is:coexpr(ce) then runerr(118,ce) - - if is:null(cs) then { - abstract { - return cset++null - } - body { - result = BlkLoc(ce)->coexpr.program->opcodemask; - return result; - } - } - else if !cnv:cset(cs) then runerr(104,cs) - else { - abstract { - return cset - } - body { - ((struct b_coexpr *)BlkLoc(ce))->program->opcodemask = cs; - return cs; - } - } -end -#endif /* EventMon */ - - -"structure(x) -- generate all structures allocated in program x" -function {*} structure(x) - - if !is:coexpr(x) then - runerr(118, x) - - abstract { - return list ++ set ++ table ++ record - } - - body { - tended char *bp; - char *free; - tended struct descrip descr; - word type; - struct region *theregion, *rp; - -#ifdef MultiThread - theregion = ((struct b_coexpr *)BlkLoc(x))->program->blockregion; -#else - theregion = curblock; -#endif - for(rp = theregion; rp; rp = rp->next) { - bp = rp->base; - free = rp->free; - while (bp < free) { - type = BlkType(bp); - switch (type) { - case T_List: - case T_Set: - case T_Table: - case T_Record: { - BlkLoc(descr) = (union block *)bp; - descr.dword = type | F_Ptr | D_Typecode; - suspend descr; - } - } - bp += BlkSize(bp); - } - } - for(rp = theregion->prev; rp; rp = rp->prev) { - bp = rp->base; - free = rp->free; - while (bp < free) { - type = BlkType(bp); - switch (type) { - case T_List: - case T_Set: - case T_Table: - case T_Record: { - BlkLoc(descr) = (union block *)bp; - descr.dword = type | F_Ptr | D_Typecode; - suspend descr; - } - } - bp += BlkSize(bp); - } - } - fail; - } -end - - -#endif /* MultiThread */ diff --git a/src/runtime/fmonitr.r b/src/runtime/fmonitr.r deleted file mode 100644 index 8eeb95e..0000000 --- a/src/runtime/fmonitr.r +++ /dev/null @@ -1,273 +0,0 @@ -/* - * fmonitr.r -- event, EvGet - * - * This file contains event monitoring code, used only if EventMon - * (event monitoring) is defined. Event monitoring is normally is - * not enabled. - */ - -#ifdef EventMon - -/* - * Prototypes. - */ - -void mmrefresh (void); - -#define evforget() - - -char typech[MaxType+1]; /* output character for each type */ - -int noMTevents; /* don't produce events in EVAsgn */ - -#ifdef MultiThread - -static char scopechars[] = "+:^-"; - -/* - * Special event function for E_Assign; allocates out of monitor's heap. - */ -void EVAsgn(dx) -dptr dx; -{ - int i; - dptr procname; - struct progstate *parent = curpstate->parent; - struct region *rp = curpstate->stringregion; - -#if COMPILER - procname = &(PFDebug(*pfp)->proc->pname); -#else /* COMPILER */ - procname = &((&BlkLoc(*glbl_argp)->proc)->pname); -#endif /* COMPILER */ - /* - * call get_name, allocating out of the monitor if necessary. - */ - curpstate->stringregion = parent->stringregion; - parent->stringregion = rp; - noMTevents++; - i = get_name(dx,&(parent->eventval)); - - if (i == GlobalName) { - if (reserve(Strings, StrLen(parent->eventval) + 1) == NULL) - syserr("event monitoring out-of-memory error"); - StrLoc(parent->eventval) = - alcstr(StrLoc(parent->eventval), StrLen(parent->eventval)); - alcstr("+",1); - StrLen(parent->eventval)++; - } - else if (i == StaticName || i == LocalName || i == ParamName) { - if (!reserve(Strings, StrLen(parent->eventval) + StrLen(*procname) + 1)) - syserr("event monitoring out-of-memory error"); - StrLoc(parent->eventval) = - alcstr(StrLoc(parent->eventval), StrLen(parent->eventval)); - alcstr(scopechars+i,1); - alcstr(StrLoc(*procname), StrLen(*procname)); - StrLen(parent->eventval) += StrLen(*procname) + 1; - } - else if (i == Error) { - noMTevents--; - return; /* should be more violent than this */ - } - - parent->stringregion = curpstate->stringregion; - curpstate->stringregion = rp; - noMTevents--; - actparent(E_Assign); -} - - -/* - * event(x, y, C) -- generate an event at the program level. - */ - -"event(x, y, C) - create event with event code x and event value y." - -function{0,1} event(x,y,ce) - body { - struct progstate *dest; - - if (is:null(x)) { - x = curpstate->eventcode; - if (is:null(y)) y = curpstate->eventval; - } - if (is:null(ce) && is:coexpr(curpstate->parentdesc)) - ce = curpstate->parentdesc; - else if (!is:coexpr(ce)) runerr(118,ce); - dest = BlkLoc(ce)->coexpr.program; - dest->eventcode = x; - dest->eventval = y; - if (mt_activate(&(dest->eventcode),&result, - (struct b_coexpr *)BlkLoc(ce)) == A_Cofail) { - fail; - } - return result; - } -end - -/* - * EvGet(c) - user function for reading event streams. - */ - -"EvGet(c,flag) - read through the next event token having a code matched " -" by cset c." - -/* - * EvGet returns the code of the matched token. These keywords are also set: - * &eventcode token code - * &eventvalue token value - */ -function{0,1} EvGet(cs,flag) - if !def:cset(cs,fullcs) then - runerr(104,cs) - - body { - register int c; - tended struct descrip dummy; - struct progstate *p; - - /* - * Be sure an eventsource is available - */ - if (!is:coexpr(curpstate->eventsource)) - runerr(118,curpstate->eventsource); - - /* - * If our event source is a child of ours, assign its event mask. - */ - p = BlkLoc(curpstate->eventsource)->coexpr.program; - if (p->parent == curpstate) - p->eventmask = cs; - -#ifdef Graphics - if (Testb((word)E_MXevent, cs) && - is:file(kywd_xwin[XKey_Window])) { - wbp _w_ = (wbp)BlkLoc(kywd_xwin[XKey_Window])->file.fd; - pollctr = pollevent(); - if (pollctr == -1) - fatalerr(141, NULL); - if (BlkLoc(_w_->window->listp)->list.size > 0) { - c = wgetevent(_w_, &curpstate->eventval); - if (c == 0) { - StrLen(curpstate->eventcode) = 1; - StrLoc(curpstate->eventcode) = - (char *)&allchars[E_MXevent & 0xFF]; - return curpstate->eventcode; - } - else if (c == -1) - runerr(141); - else - runerr(143); - } - } -#endif /* Graphics */ - - /* - * Loop until we read an event allowed. - */ - while (1) { - /* - * Activate the event source to produce the next event. - */ - dummy = cs; - if (mt_activate(&dummy, &curpstate->eventcode, - (struct b_coexpr *)BlkLoc(curpstate->eventsource)) == - A_Cofail) fail; - deref(&curpstate->eventcode, &curpstate->eventcode); - if (!is:string(curpstate->eventcode) || - StrLen(curpstate->eventcode) != 1) { - /* - * this event is out-of-band data; return or reject it - * depending on whether flag is null. - */ - if (!is:null(flag)) - return curpstate->eventcode; - else continue; - } - - switch(*StrLoc(curpstate->eventcode)) { - case E_Cofail: case E_Coret: { - if (BlkLoc(curpstate->eventsource)->coexpr.id == 1) { - fail; - } - } - } - - return curpstate->eventcode; - } - } -end - -#endif /* MultiThread */ - -/* - * EVInit() - initialization. - */ - -void EVInit() - { - int i; - - /* - * Initialize the typech array, which is used if either file-based - * or MT-based event monitoring is enabled. - */ - - for (i = 0; i <= MaxType; i++) - typech[i] = '?'; /* initialize with error character */ - -#ifdef LargeInts - typech[T_Lrgint] = E_Lrgint; /* long integer */ -#endif /* LargeInts */ - - typech[T_Real] = E_Real; /* real number */ - typech[T_Cset] = E_Cset; /* cset */ - typech[T_File] = E_File; /* file block */ - typech[T_Record] = E_Record; /* record block */ - typech[T_Tvsubs] = E_Tvsubs; /* substring trapped variable */ - typech[T_External]= E_External; /* external block */ - typech[T_List] = E_List; /* list header block */ - typech[T_Lelem] = E_Lelem; /* list element block */ - typech[T_Table] = E_Table; /* table header block */ - typech[T_Telem] = E_Telem; /* table element block */ - typech[T_Tvtbl] = E_Tvtbl; /* table elem trapped variable*/ - typech[T_Set] = E_Set; /* set header block */ - typech[T_Selem] = E_Selem; /* set element block */ - typech[T_Slots] = E_Slots; /* set/table hash slots */ - typech[T_Coexpr] = E_Coexpr; /* co-expression block (static) */ - typech[T_Refresh] = E_Refresh; /* co-expression refresh block */ - - - /* - * codes used elsewhere but not shown here: - * in the static region: E_Alien = alien (malloc block) - * in the static region: E_Free = free - * in the string region: E_String = string - */ - } - -/* - * mmrefresh() - redraw screen, initially or after garbage collection. - */ - -void mmrefresh() - { - char *p; - word n; - - /* - * If the monitor is asking for E_EndCollect events, then it - * can handle these memory allocation "redraw" events. - */ - if (!is:null(curpstate->eventmask) && - Testb((word)E_EndCollect, curpstate->eventmask)) { - for (p = blkbase; p < blkfree; p += n) { - n = BlkSize(p); - EVVal(n, typech[(int)BlkType(p)]); /* block region */ - } - EVVal(DiffPtrs(strfree, strbase), E_String); /* string region */ - } - } - -#endif /* EventMon */ diff --git a/src/runtime/fscan.r b/src/runtime/fscan.r index 8cba731..9e974d8 100644 --- a/src/runtime/fscan.r +++ b/src/runtime/fscan.r @@ -34,7 +34,6 @@ function{0,1+} move(i) * Set new &pos. */ k_pos += i; - EVVal(k_pos, E_Spos); /* * Make sure i >= 0. @@ -56,7 +55,6 @@ function{0,1+} move(i) runerr(205, kywd_pos); else { k_pos = oldpos; - EVVal(k_pos, E_Spos); } fail; @@ -116,7 +114,6 @@ function{0,1+} tab(i) * Set new &pos. */ k_pos = i; - EVVal(k_pos, E_Spos); /* * Make i the length of the substring &subject[i:j] @@ -141,7 +138,6 @@ function{0,1+} tab(i) runerr(205, kywd_pos); else { k_pos = oldpos; - EVVal(k_pos, E_Spos); } fail; diff --git a/src/runtime/fstr.r b/src/runtime/fstr.r index 08d9f10..974aa56 100644 --- a/src/runtime/fstr.r +++ b/src/runtime/fstr.r @@ -214,10 +214,6 @@ function{1} detab(s,i[n]) return result; else { long n = DiffPtrs(StrLoc(result),strfree); /* note deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(StrLoc(result),strfree); strfree = StrLoc(result); /* reset the free pointer */ return s; /* return original string */ @@ -337,20 +333,12 @@ function{1} entab(s,i[n]) long n; StrLen(result) = DiffPtrs(out,StrLoc(result)); n = DiffPtrs(out,strfree); /* note the deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(out,strfree); strfree = out; /* give back unused space */ return result; /* return new string */ } else { long n = DiffPtrs(StrLoc(result),strfree); /* note the deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(StrLoc(result),strfree); strfree = StrLoc(result); /* reset free pointer */ return s; /* return original string */ @@ -445,12 +433,6 @@ function{1} map(s1,s2,s3) */ if !cnv:string(s1) then runerr(103,s1) -#if COMPILER - if !def:string(s2, ucase) then - runerr(103,s2) - if !def:string(s3, lcase) then - runerr(103,s3) -#endif /* COMPILER */ abstract { return string @@ -461,12 +443,11 @@ function{1} map(s1,s2,s3) register char *str1, *str2, *str3; static char maptab[256]; -#if !COMPILER if (is:null(s2)) s2 = ucase; if (is:null(s3)) s3 = lcase; -#endif /* !COMPILER */ + /* * If s2 and s3 are the same as for the last call of map, * the current values in maptab can be used. Otherwise, the @@ -475,13 +456,11 @@ function{1} map(s1,s2,s3) if (!EqlDesc(maps2,s2) || !EqlDesc(maps3,s3)) { maps2 = s2; maps3 = s3; - -#if !COMPILER if (!cnv:string(s2,s2)) runerr(103,s2); if (!cnv:string(s3,s3)) runerr(103,s3); -#endif /* !COMPILER */ + /* * s2 and s3 must be of the same length */ diff --git a/src/runtime/fstruct.r b/src/runtime/fstruct.r index 469c3c5..3e5972a 100644 --- a/src/runtime/fstruct.r +++ b/src/runtime/fstruct.r @@ -34,8 +34,6 @@ function{1} delete(s,x) (BlkLoc(s)->set.size)--; } - EVValD(&s, E_Sdelete); - EVValD(&x, E_Sval); return s; } table: @@ -54,8 +52,6 @@ function{1} delete(s,x) (BlkLoc(s)->table.size)--; } - EVValD(&s, E_Tdelete); - EVValD(&x, E_Tsub); return s; } default: @@ -89,11 +85,7 @@ struct descrip *res; if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listnext; hp->listhead = (union block *) bp; -#ifdef ListFix - bp->listprev = (union block *) hp; -#else /* ListFix */ bp->listprev = NULL; -#endif /* ListFix */ } /* @@ -131,7 +123,6 @@ function{0,1} get_or_pop(x) } body { - EVValD(&x, E_Lget); if (!c_get((struct b_list *)BlkLoc(x), &result)) fail; return result; } @@ -156,10 +147,8 @@ function{*} key(t) tended union block *ep; struct hgstate state; - EVValD(&t, E_Tkey); for (ep = hgfirst(BlkLoc(t), &state); ep != 0; ep = hgnext(BlkLoc(t), &state, ep)) { - EVValD(&ep->telem.tref, E_Tsub); suspend ep->telem.tref; } fail; @@ -215,8 +204,6 @@ function{1} insert(s, x, y) else deallocate((union block *)se); - EVValD(&s, E_Sinsert); - EVValD(&x, E_Sval); return s; } } @@ -264,8 +251,6 @@ function{1} insert(s, x, y) te->tval = y; } - EVValD(&s, E_Tinsert); - EVValD(&x, E_Tsub); return s; } } @@ -313,9 +298,6 @@ function{1} list(n, x) Protect(hp = alclist(size), runerr(0)); Protect(bp = alclstb(nslots, (word)0, size), runerr(0)); hp->listhead = hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *) hp; -#endif /* ListFix */ /* * Initialize each slot. @@ -323,8 +305,6 @@ function{1} list(n, x) for (i = 0; i < size; i++) bp->lslots[i] = x; - Desc_EVValD(hp, E_Lcreate, D_List); - /* * Return the new list. */ @@ -347,9 +327,6 @@ function{0,1} member(s, x) int res; register uword hn; - EVValD(&s, E_Smember); - EVValD(&x, E_Sval); - hn = hash(&x); memb(BlkLoc(s), &x, hn, &res); if (res==1) @@ -366,9 +343,6 @@ function{0,1} member(s, x) int res; register uword hn; - EVValD(&s, E_Tmember); - EVValD(&x, E_Tsub); - hn = hash(&x); memb(BlkLoc(s), &x, hn, &res); if (res == 1) @@ -400,8 +374,6 @@ function{0,1} pull(x) register struct b_list *hp; register struct b_lelem *bp; - EVValD(&x, E_Lpull); - /* * Point at list header block and fail if the list is empty. */ @@ -417,11 +389,7 @@ function{0,1} pull(x) if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listprev; hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listnext = (union block *) hp; -#else /* ListFix */ bp->listnext = NULL; -#endif /* ListFix */ } /* @@ -456,10 +424,6 @@ dptr val; */ bp = (struct b_lelem *) BlkLoc(*l)->list.listhead; -#ifdef EventMon /* initialize i so it's 0 if first list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the first list-element block is full, allocate a new * list-element block, make it the first list-element block, @@ -489,9 +453,6 @@ dptr val; } BlkLoc(*l)->list.listhead->lelem.listprev = (union block *) bp; -#ifdef ListFix - bp->listprev = BlkLoc(*l); -#endif /* ListFix */ bp->listnext = BlkLoc(*l)->list.listhead; BlkLoc(*l)->list.listhead = (union block *) bp; } @@ -553,10 +514,6 @@ function{1} push(x, vals[n]) hp = (struct b_list *) BlkLoc(x); bp = (struct b_lelem *) hp->listhead; -#ifdef EventMon /* initialize i so it's 0 if first list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the first list-element block is full, allocate a new * list-element block, make it the first list-element block, @@ -586,9 +543,6 @@ function{1} push(x, vals[n]) } hp->listhead->lelem.listprev = (union block *) bp; -#ifdef ListFix - bp->listprev = (union block *) hp; -#endif /* ListFix */ bp->listnext = hp->listhead; hp->listhead = (union block *) bp; } @@ -610,8 +564,6 @@ function{1} push(x, vals[n]) hp->size++; } - EVValD(&x, E_Lpush); - /* * Return the list. */ @@ -637,10 +589,6 @@ struct descrip *val; */ bp = (struct b_lelem *) BlkLoc(*l)->list.listtail; -#ifdef EventMon /* initialize i so it's 0 if last list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the last list-element block is full, allocate a new * list-element block, make it the last list-element block, @@ -672,9 +620,6 @@ struct descrip *val; ((struct b_list *)BlkLoc(*l))->listtail->lelem.listnext = (union block *) bp; bp->listprev = ((struct b_list *)BlkLoc(*l))->listtail; -#ifdef ListFix - bp->listnext = BlkLoc(*l); -#endif /* ListFix */ ((struct b_list *)BlkLoc(*l))->listtail = (union block *) bp; } @@ -733,10 +678,6 @@ function{1} put(x, vals[n]) hp = (struct b_list *)BlkLoc(x); bp = (struct b_lelem *) hp->listtail; -#ifdef EventMon /* initialize i so it's 0 if last list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the last list-element block is full, allocate a new * list-element block, make it the last list-element block, @@ -766,9 +707,6 @@ function{1} put(x, vals[n]) hp->listtail->lelem.listnext = (union block *) bp; bp->listprev = hp->listtail; -#ifdef ListFix - bp->listnext = (union block *)hp; -#endif /* ListFix */ hp->listtail = (union block *) bp; } @@ -789,8 +727,6 @@ function{1} put(x, vals[n]) } - EVValD(&x, E_Lput); - /* * Return the list. */ @@ -815,7 +751,6 @@ function{1} set(l) ps = hmake(T_Set, (word)0, (word)0); if (ps == NULL) runerr(0); - Desc_EVValD(ps, E_Screate, D_Set); return set(ps); } } @@ -854,11 +789,7 @@ function{1} set(l) Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0)); for (pb = pb->list.listhead; -#ifdef ListFix - BlkType(pb) == T_Lelem; -#else /* ListFix */ pb != NULL; -#endif /* ListFix */ pb = pb->lelem.listnext) { for (i = 0; i < pb->lelem.nused; i++) { j = pb->lelem.first + i; @@ -876,7 +807,6 @@ function{1} set(l) } } deallocate((union block *)ne); - Desc_EVValD(ps, E_Screate, D_Set); return set(ps); } } @@ -900,7 +830,6 @@ function{1} table(x) if (bp == NULL) runerr(0); bp->table.defvalue = x; - Desc_EVValD(bp, E_Tcreate, D_Table); return table(bp); } end diff --git a/src/runtime/fsys.r b/src/runtime/fsys.r index 6b70b65..6889515 100644 --- a/src/runtime/fsys.r +++ b/src/runtime/fsys.r @@ -262,9 +262,6 @@ function{0,1} open(fname, spec) Protect(hp = alclist(0), runerr(0)); Protect(bp = alclstb(MinListSlots, (word)0, 0), runerr(0)); hp->listhead = hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *) hp; -#endif /* ListFix */ /* * loop through attributes, checking validity @@ -537,10 +534,6 @@ function{0,1} reads(f,i) * We may not have used the entire amount of storage we reserved. */ nbytes = DiffPtrs(StrLoc(s) + tally, strfree); - if (nbytes < 0) - EVVal(-nbytes, E_StrDeAlc); - else - EVVal(nbytes, E_String); strtotal += nbytes; strfree = StrLoc(s) + tally; return s; diff --git a/src/runtime/fwindow.r b/src/runtime/fwindow.r index 010286f..cc1b9c7 100644 --- a/src/runtime/fwindow.r +++ b/src/runtime/fwindow.r @@ -1624,29 +1624,18 @@ function{3} Pixel(argv[argc]) Protect((StrLoc(lastval) = alcstr(strout, slen)), runerr(0)); StrLen(lastval) = slen; } -#if COMPILER - suspend lastval; /* memory leak on vanquish */ -#else /* COMPILER */ /* * suspend, but free up imem if vanquished; RTL workaround * Needs implementing under the compiler. */ r_args[0] = lastval; -#ifdef EventMon - if ((signal = interp(G_Fsusp, r_args)) != A_Resume) { -#else /* EventMon */ if ((signal = interp(G_Csusp, r_args)) != A_Resume) { -#endif /* EventMon */ tend = r_tend.previous; getpixel_term(w, &imem); VanquishReturn(signal); } -#endif /* COMPILER */ } else { -#if COMPILER - suspend C_integer rv; /* memory leak on vanquish */ -#else /* COMPILER */ int signal; /* * suspend, but free up imem if vanquished; RTL workaround @@ -1654,16 +1643,11 @@ function{3} Pixel(argv[argc]) */ r_args[0].dword = D_Integer; r_args[0].vword.integr = rv; -#ifdef EventMon - if ((signal = interp(G_Fsusp, r_args)) != A_Resume) { -#else /* EventMon */ if ((signal = interp(G_Csusp, r_args)) != A_Resume) { -#endif /* EventMon */ tend = r_tend.previous; getpixel_term(w, &imem); VanquishReturn(signal); } -#endif /* COMPILER */ } } } diff --git a/src/runtime/imain.r b/src/runtime/imain.r index 424a4f6..7286666 100644 --- a/src/runtime/imain.r +++ b/src/runtime/imain.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: imain.r * Interpreter main program, argument handling, and such. @@ -28,36 +27,6 @@ int iconx(int argc, char *argv[]) { static word istart[4]; static int mterm = Op_Quit; - #ifdef MultiThread - /* - * Look for MultiThread programming environment in which to execute - * this program, specified by MTENV environment variable. - */ - { - char *p; - char **new_argv; - int i, j = 1, k = 1; - if ((p = getenv("MTENV")) != NULL) { - for(i=0;p[i];i++) - if (p[i] == ' ') - j++; - new_argv = malloc((argc + j) * sizeof(char *)); - new_argv[0] = argv[0]; - for (i=0; p[i]; ) { - new_argv[k++] = p+i; - while (p[i] && (p[i] != ' ')) - i++; - if (p[i] == ' ') - p[i++] = '\0'; - } - for(i=1;i<argc;i++) - new_argv[k++] = argv[i]; - argc += j; - argv = new_argv; - } - } - #endif /* MultiThread */ - ipc.opnd = NULL; #ifdef LoadFunc @@ -69,7 +38,7 @@ int iconx(int argc, char *argv[]) { p = getenv("FPATH"); q = relfile(argv[0], "/.."); sprintf(buf, "FPATH=%s %s", (p ? p : "."), (q ? q : ".")); - putenv(buf); + putenv(salloc(buf)); } #endif /* LoadFunc */ @@ -191,54 +160,8 @@ int argc; char **argv; int *ip; { - - #ifdef TallyOpt - extern int tallyopt; - #endif /* TallyOpt */ - *ip = 0; /* number of arguments processed */ - #if MSWIN - /* - * if we didn't start with iconx.exe, backup one - * so that our icode filename is argv[1]. - */ - { - char tmp[256], *t2, *basename, *ext; - int len = 0; - strcpy(tmp, argv[0]); - for (t2 = tmp; *t2; t2++) { - switch (*t2) { - case ':': - case '/': - case '\\': - basename = t2 + 1; - ext = NULL; - break; - case '.': - ext = t2; - break; - default: - *t2 = tolower(*t2); - break; - } - } - /* If present, cut the ".exe" extension. */ - if (ext != NULL && !strcmp(ext, ".exe")) - *ext = 0; - - /* - * if argv[0] is not a reference to our interpreter, take it as the - * name of the icode file, and back up for it. - */ - if (strcmp(basename, "iconx")) { - argv--; - argc++; - (*ip)--; - } - } - #endif /* MSWIN */ - /* * Handle command line options. */ @@ -246,20 +169,12 @@ int *ip; switch ( *(argv[1]+1) ) { - #ifdef TallyOpt - /* - * Set tallying flag if -T option given - */ - case 'T': - tallyopt = 1; - break; - #endif /* TallyOpt */ - /* * Announce version on stderr if -V is given. */ case 'V': - fprintf(stderr, "%s (%s, %s)\n", Version, Config, __DATE__); + fprintf(stderr, "%s (%s %d/%d, %s)\n", + Version, Config, IntBits, WordBits, __DATE__); if (!argv[2]) exit(0); break; @@ -276,26 +191,13 @@ int *ip; * resolve - perform various fix-ups on the data read from the icode * file. */ -#ifdef MultiThread - void resolve(pstate) - struct progstate *pstate; -#else /* MultiThread */ - void resolve() -#endif /* MultiThread */ +void resolve() { register word i, j; register struct b_proc *pp; register dptr dp; extern int Omkrec(); - #ifdef MultiThread - register struct progstate *savedstate; - #endif /* MultiThread */ - - #ifdef MultiThread - savedstate = curpstate; - if (pstate) curpstate = pstate; - #endif /* MultiThread */ /* * Relocate the names of the global variables. @@ -372,13 +274,6 @@ int *ip; /* * Relocate the names of the fields. */ - for (dp = fnames; dp < efnames; dp++) StrLoc(*dp) = strcons + (uword)StrLoc(*dp); - - #ifdef MultiThread - curpstate = savedstate; - #endif /* MultiThread */ } - -#endif /* !COMPILER */ diff --git a/src/runtime/imisc.r b/src/runtime/imisc.r index cde8a90..758a0ab 100644 --- a/src/runtime/imisc.r +++ b/src/runtime/imisc.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: imisc.r * Contents: field, mkrec, limit, llist, bscan, escan @@ -14,18 +13,8 @@ LibDcl(field,2,".") register struct b_record *rp; register dptr dp; -#ifdef MultiThread - register union block *bptr; -#else /* MultiThread */ extern int *ftabp; - #ifdef FieldTableCompression - extern int *fo; - extern unsigned char *focp; - extern short *fosp; - extern char *bm; - #endif /* FieldTableCompression */ extern word *records; -#endif /* MultiThread */ Deref(Arg1); @@ -41,74 +30,14 @@ LibDcl(field,2,".") * Map the field number into a field number for the record x. */ rp = (struct b_record *) BlkLoc(Arg1); - -#ifdef MultiThread - bptr = rp->recdesc; - if (!InRange(curpstate->Records, bptr, curpstate->Ftabp)) { - int i; - int nfields = bptr->proc.nfields; - /* - * Look up the field number by a brute force search through - * the record constructor's field names. - */ - Arg0 = fnames[IntVal(Arg2)]; - fprintf(stderr,"looking up interprogram field %.*s\n", StrLen(Arg0), - StrLoc(Arg0)); - for (i=0;i<nfields;i++){ - if ((StrLen(Arg0) == StrLen(bptr->proc.lnames[i])) && - !strncmp(StrLoc(Arg0), StrLoc(bptr->proc.lnames[i]),StrLen(Arg0))) - break; - } - if (i<nfields) fnum = i; - else fnum = -1; - } - else -#endif /* MultiThread */ - -#ifdef FieldTableCompression -#define FO(i) ((foffwidth==1)?focp[i]:((foffwidth==2)?fosp[i]:fo[i])) -#define FTAB(i) ((ftabwidth==1)?ftabcp[i]:((ftabwidth==2)?ftabsp[i]:ftabp[i])) -#else /* FieldTableCompression */ -#define FO(i) fo[i] -#define FTAB(i) ftabp[i] -#endif /* FieldTableCompression */ - -#ifdef FieldTableCompression - fnum = FTAB(FO(IntVal(Arg2)) + (rp->recdesc->proc.recnum - 1)); -#else /* FieldTableCompression */ - fnum = FTAB(IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1); -#endif /* FieldTableCompression */ + fnum = ftabp[IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1]; /* * If fnum < 0, x doesn't contain the specified field. */ - -#ifdef FieldTableCompression -{ - int bytes, index; - unsigned char this_bit = 0200; - - bytes = *records >> 3; - if ((*records & 07) != 0) - bytes++; - index = IntVal(Arg2) * bytes + (rp->recdesc->proc.recnum - 1) / 8; - this_bit = this_bit >> (rp->recdesc->proc.recnum - 1) % 8; - if ((bm[index] | this_bit) != bm[index]) - RunErr(207, &Arg1); -} - - if (ftabwidth == 1) { - if (fnum == 255) - RunErr(207, &Arg1); - } - else -#endif /* FieldTableCompression */ if (fnum < 0) RunErr(207, &Arg1); - EVValD(&Arg1, E_Rref); - EVVal(fnum + 1, E_Rsub); - /* * Return a pointer to the descriptor for the appropriate field. */ @@ -156,7 +85,6 @@ LibDcl(mkrec,-1,"mkrec") ArgType(0) = D_Record; Arg0.vword.bptr = (union block *)rp; - EVValD(&Arg0, E_Rcreate); Return; } @@ -215,8 +143,6 @@ LibDcl(bscan,2,"?") if (!cnv:string(Arg0,Arg0)) RunErr(103, &Arg0); - EVValD(&Arg0, E_Snew); - /* * Establish a new &subject value and set &pos to 1. */ @@ -238,13 +164,6 @@ LibDcl(bscan,2,"?") rc = interp(G_Csusp,cargp); -#ifdef EventMon - if (rc != A_Resume) - EVValD(&Arg1, E_Srem); - else - EVValD(&Arg1, E_Sfail); -#endif /* EventMon */ - if (pfp != cur_pfp) return rc; @@ -326,8 +245,6 @@ LibDcl(escan,1,"escan") * Suspend with the value of the scanning expression. */ - EVValD(&k_subject, E_Ssusp); - rc = interp(G_Csusp,cargp); if (pfp != cur_pfp) return rc; @@ -340,11 +257,6 @@ LibDcl(escan,1,"escan") k_subject = *VarLoc(Arg1); *VarLoc(Arg1) = tmp; -#ifdef EventMon - if (rc == A_Resume) - EVValD(&k_subject, E_Sresum); -#endif /* EventMon */ - tmp = *(VarLoc(Arg1) + 1); IntVal(*(VarLoc(Arg1) + 1)) = k_pos; k_pos = IntVal(tmp); @@ -354,4 +266,3 @@ LibDcl(escan,1,"escan") return rc; } -#endif /* !COMPILER */ diff --git a/src/runtime/init.r b/src/runtime/init.r index 248bda8..d0bc00b 100644 --- a/src/runtime/init.r +++ b/src/runtime/init.r @@ -9,19 +9,18 @@ static void env_err (char *msg, char *name, char *val); FILE *pathOpen (char *fname, char *mode); -#if !COMPILER - #include "../h/header.h" - static FILE *readhdr(char *name, struct header *hdr); +#include "../h/header.h" +static FILE *readhdr(char *name, struct header *hdr); - #passthru #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); - #passthru #include "../h/odefs.h" - #passthru #undef OpDef +#passthru #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); +#passthru #include "../h/odefs.h" +#passthru #undef OpDef - /* - * External declarations for operator blocks. - */ +/* + * External declarations for operator blocks. + */ - #passthru #define OpDef(f,nargs,sname,underef)\ +#passthru #define OpDef(f,nargs,sname,underef)\ {\ T_Proc,\ Vsizeof(struct b_proc),\ @@ -31,11 +30,10 @@ FILE *pathOpen (char *fname, char *mode); underef,\ 0,\ {{sizeof(sname)-1,sname}}}, - #passthru static B_IProc(2) init_op_tbl[] = { - #passthru #include "../h/odefs.h" - #passthru }; - #undef OpDef -#endif /* !COMPILER */ +#passthru static B_IProc(2) init_op_tbl[] = { +#passthru #include "../h/odefs.h" +#passthru }; +#undef OpDef #ifdef WinGraphics static void MSStartup(HINSTANCE hInstance, HINSTANCE hPrevInstance); @@ -58,10 +56,7 @@ word mstksize = MStackSize; /* initial size of main stack */ word stksize = StackSize; /* co-expression stack size */ int k_level = 0; /* &level */ - -#ifndef MultiThread - struct descrip k_main; /* &main */ -#endif /* MultiThread */ +struct descrip k_main; /* &main */ int ixinited = 0; /* set-up switch */ @@ -74,10 +69,8 @@ word memcushion = RegionCushion; /* memory region cushion factor */ word memgrowth = RegionGrowth; /* memory region growth factor */ uword stattotal = 0; /* cumulative total static allocation */ -#ifndef MultiThread - uword strtotal = 0; /* cumulative total string allocation */ - uword blktotal = 0; /* cumulative total block allocation */ -#endif /* MultiThread */ +uword strtotal = 0; /* cumulative total string allocation */ +uword blktotal = 0; /* cumulative total block allocation */ int dodump; /* if nonzero, core dump on error */ int noerrbuf; /* if nonzero, do not buffer stderr */ @@ -85,16 +78,14 @@ int noerrbuf; /* if nonzero, do not buffer stderr */ struct descrip maps2; /* second cached argument of map */ struct descrip maps3; /* third cached argument of map */ -#ifndef MultiThread - struct descrip k_current; /* current expression stack pointer */ - int k_errornumber = 0; /* &errornumber */ - char *k_errortext = ""; /* &errortext */ - struct descrip k_errorvalue; /* &errorvalue */ - int have_errval = 0; /* &errorvalue has legal value */ - int t_errornumber = 0; /* tentative k_errornumber value */ - int t_have_val = 0; /* tentative have_errval flag */ - struct descrip t_errorvalue; /* tentative k_errorvalue value */ -#endif /* MultiThread */ +struct descrip k_current; /* current expression stack pointer */ +int k_errornumber = 0; /* &errornumber */ +char *k_errortext = ""; /* &errortext */ +struct descrip k_errorvalue; /* &errorvalue */ +int have_errval = 0; /* &errorvalue has legal value */ +int t_errornumber = 0; /* tentative k_errornumber value */ +int t_have_val = 0; /* tentative have_errval flag */ +struct descrip t_errorvalue; /* tentative k_errorvalue value */ struct b_coexpr *stklist; /* base of co-expression block list */ @@ -102,80 +93,38 @@ struct tend_desc *tend = NULL; /* chain of tended descriptors */ struct region rootstring, rootblock; -#ifndef MultiThread - dptr glbl_argp = NULL; /* argument pointer */ - dptr globals, eglobals; /* pointer to global variables */ - dptr gnames, egnames; /* pointer to global variable names */ - dptr estatics; /* pointer to end of static variables */ - struct region *curstring, *curblock; - #if !COMPILER - int n_globals = 0; /* number of globals */ - int n_statics = 0; /* number of statics */ - #endif /* !COMPILER */ -#endif /* MultiThread */ - -#if COMPILER - struct p_frame *pfp = NULL; /* procedure frame pointer */ - - int debug_info; /* flag: is debugging information available */ - int err_conv; /* flag: is error conversion supported */ - int largeints; /* flag: large integers are supported */ - - struct b_coexpr *mainhead; /* &main */ - -#else /* COMPILER */ - - int debug_info=1; /* flag: debugging information IS available */ - int err_conv=1; /* flag: error conversion IS supported */ - - int op_tbl_sz = (sizeof(init_op_tbl) / sizeof(struct b_proc)); - struct pf_marker *pfp = NULL; /* Procedure frame pointer */ - - #ifdef MultiThread - struct progstate *curpstate; /* lastop accessed in program state */ - struct progstate rootpstate; - #else /* MultiThread */ - - struct b_coexpr *mainhead; /* &main */ - - char *code; /* interpreter code buffer */ - char *ecode; /* end of interpreter code buffer */ - word *records; /* pointer to record procedure blocks */ - - int *ftabp; /* pointer to record/field table */ - - #ifdef FieldTableCompression - word ftabwidth; /* field table entry width */ - word foffwidth; /* field offset entry width */ - unsigned char *ftabcp, *focp; /* pointers to record/field table */ - short *ftabsp, *fosp; /* pointers to record/field table */ - - int *fo; /* field offset (row in field table) */ - char *bm; /* bitmap array of valid field bits */ - #endif /* FieldTableCompression */ - - dptr fnames, efnames; /* pointer to field names */ - dptr statics; /* pointer to static variables */ - char *strcons; /* pointer to string constant table */ - struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */ - struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */ - #endif /* MultiThread */ - - #ifdef TallyOpt - word tallybin[16]; /* counters for tallying */ - int tallyopt = 0; /* want tally results output? */ - #endif /* TallyOpt */ - - word *stack; /* Interpreter stack */ - word *stackend; /* End of interpreter stack */ - -#endif /* COMPILER */ +dptr glbl_argp = NULL; /* argument pointer */ +dptr globals, eglobals; /* pointer to global variables */ +dptr gnames, egnames; /* pointer to global variable names */ +dptr estatics; /* pointer to end of static variables */ +struct region *curstring, *curblock; +int n_globals = 0; /* number of globals */ +int n_statics = 0; /* number of statics */ + +int debug_info=1; /* flag: debugging information IS available */ +int err_conv=1; /* flag: error conversion IS supported */ + +int op_tbl_sz = (sizeof(init_op_tbl) / sizeof(struct b_proc)); +struct pf_marker *pfp = NULL; /* Procedure frame pointer */ + + struct b_coexpr *mainhead; /* &main */ + + char *code; /* interpreter code buffer */ + char *ecode; /* end of interpreter code buffer */ + word *records; /* pointer to record procedure blocks */ + int *ftabp; /* pointer to record/field table */ + dptr fnames, efnames; /* pointer to field names */ + dptr statics; /* pointer to static variables */ + char *strcons; /* pointer to string constant table */ + struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */ + struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */ + +word *stack; /* Interpreter stack */ +word *stackend; /* End of interpreter stack */ -#if !COMPILER - /* * Open the icode file and read the header. - * Used by icon_init() as well as MultiThread's loadicode() + * Used by icon_init(). */ static FILE *readhdr(name,hdr) char *name; @@ -249,35 +198,21 @@ struct header *hdr; return fname; } - -#endif /* !COMPILER */ /* * init/icon_init - initialize memory and prepare for Icon execution. */ -#if !COMPILER - struct header hdr; -#endif /* !COMPILER */ - -#if COMPILER - void init(name, argcp, argv, trc_init) - char *name; - int *argcp; - char *argv[]; - int trc_init; -#else /* COMPILER */ - void icon_init(name, argcp, argv) - char *name; - int *argcp; - char *argv[]; -#endif /* COMPILER */ +struct header hdr; +void icon_init(name, argcp, argv) +char *name; +int *argcp; +char *argv[]; { + char *itval; int delete_icode = 0; -#if !COMPILER FILE *fname = NULL; word cbread, longread(); -#endif /* COMPILER */ prog_name = name; /* Set icode file name */ @@ -303,80 +238,18 @@ struct header *hdr; * from icont to delete icode file xxxxx and to use yyyyy for &progname. * (This is used with Unix "#!" script files written in Icon.) */ - { - char *itval = getenv("ICODE_TEMP"); - int nlen = strlen(name); - if (itval != NULL && itval[nlen] == ':' && strncmp(name,itval,nlen)==0) { - delete_icode = 1; - prog_name = itval + nlen + 1; - } + itval = getenv("ICODE_TEMP"); + if (itval != NULL && strncmp(name, itval, strlen(name)) == 0) { + delete_icode = 1; + prog_name = strchr(itval, ':') + 1; + prog_name[-1] = '\0'; } -#if COMPILER curstring = &rootstring; curblock = &rootblock; rootstring.size = MaxStrSpace; rootblock.size = MaxAbrSize; -#else /* COMPILER */ - -#ifdef MultiThread - /* - * initialize root pstate - */ - curpstate = &rootpstate; - rootpstate.parentdesc = nulldesc; - rootpstate.eventmask= nulldesc; - rootpstate.opcodemask = nulldesc; - rootpstate.eventcode= nulldesc; - rootpstate.eventval = nulldesc; - rootpstate.eventsource = nulldesc; - rootpstate.Glbl_argp = NULL; - MakeInt(0, &(rootpstate.Kywd_err)); - MakeInt(1, &(rootpstate.Kywd_pos)); - StrLen(rootpstate.ksub) = 0; - StrLoc(rootpstate.ksub) = ""; - MakeInt(hdr.trace, &(rootpstate.Kywd_trc)); - StrLen(rootpstate.Kywd_prog) = strlen(prog_name); - StrLoc(rootpstate.Kywd_prog) = prog_name; - MakeInt(0, &(rootpstate.Kywd_ran)); - rootpstate.K_errornumber = 0; - rootpstate.T_errornumber = 0; - rootpstate.Have_errval = 0; - rootpstate.T_have_val = 0; - rootpstate.K_errortext = ""; - rootpstate.K_errorvalue = nulldesc; - rootpstate.T_errorvalue = nulldesc; - -#ifdef Graphics - MakeInt(0,&(rootpstate.AmperX)); - MakeInt(0,&(rootpstate.AmperY)); - MakeInt(0,&(rootpstate.AmperRow)); - MakeInt(0,&(rootpstate.AmperCol)); - MakeInt(0,&(rootpstate.AmperInterval)); - rootpstate.LastEventWin = nulldesc; - rootpstate.Kywd_xwin[XKey_Window] = nulldesc; -#endif /* Graphics */ - - rootpstate.Coexp_ser = 2; - rootpstate.List_ser = 1; - rootpstate.Set_ser = 1; - rootpstate.Table_ser = 1; - rootpstate.stringregion = &rootstring; - rootpstate.blockregion = &rootblock; - -#else /* MultiThread */ - - curstring = &rootstring; - curblock = &rootblock; -#endif /* MultiThread */ - - rootstring.size = MaxStrSpace; - rootblock.size = MaxAbrSize; -#endif /* COMPILER */ - -#if !COMPILER op_tbl = (struct b_proc*)init_op_tbl; -#endif /* !COMPILER */ #ifdef Double if (sizeof(struct size_dbl) != sizeof(double)) @@ -395,14 +268,10 @@ struct header *hdr; datainit(); - #if COMPILER - IntVal(kywd_trc) = trc_init; - #else /* COMPILER */ - fname = readhdr(name,&hdr); - if (fname == NULL) - error(name, "cannot open interpreter file"); - k_trace = hdr.trace; - #endif /* COMPILER */ + fname = readhdr(name,&hdr); + if (fname == NULL) + error(name, "cannot open interpreter file"); + k_trace = hdr.trace; /* * Examine the environment and make appropriate settings. [[I?]] @@ -418,41 +287,14 @@ struct header *hdr; /* * Allocate memory for various regions. */ -#if COMPILER - initalloc(); -#else /* COMPILER */ -#ifdef MultiThread - initalloc(hdr.hsize,&rootpstate); -#else /* MultiThread */ initalloc(hdr.hsize); -#endif /* MultiThread */ -#endif /* COMPILER */ -#if !COMPILER /* * Establish pointers to icode data regions. [[I?]] */ ecode = code + hdr.Records; records = (word *)ecode; ftabp = (int *)(code + hdr.Ftab); -#ifdef FieldTableCompression - fo = (int *)(code + hdr.Fo); - focp = (unsigned char *)(fo); - fosp = (short *)(fo); - if (hdr.FoffWidth == 1) { - bm = (char *)(focp + hdr.Nfields); - } - else if (hdr.FoffWidth == 2) { - bm = (char *)(fosp + hdr.Nfields); - } - else - bm = (char *)(fo + hdr.Nfields); - - ftabwidth = hdr.FtabWidth; - foffwidth = hdr.FoffWidth; - ftabcp = (unsigned char *)(code + hdr.Ftab); - ftabsp = (short *)(code + hdr.Ftab); -#endif /* FieldTableCompression */ fnames = (dptr)(code + hdr.Fnames); globals = efnames = (dptr)(code + hdr.Globals); gnames = eglobals = (dptr)(code + hdr.Gnames); @@ -465,26 +307,14 @@ struct header *hdr; strcons = (char *)elines; n_globals = eglobals - globals; n_statics = estatics - statics; -#endif /* COMPILER */ /* * Allocate stack and initialize &main. */ - -#if COMPILER - mainhead = (struct b_coexpr *)malloc(sizeof(struct b_coexpr)); -#else /* COMPILER */ stack = (word *)malloc(mstksize); mainhead = (struct b_coexpr *)stack; - -#endif /* COMPILER */ - if (mainhead == NULL) -#if COMPILER - err_msg(305, NULL); -#else /* COMPILER */ fatalerr(303, NULL); -#endif /* COMPILER */ mainhead->title = T_Coexpr; mainhead->id = 1; @@ -493,18 +323,8 @@ struct header *hdr; mainhead->es_tend = NULL; mainhead->freshblk = nulldesc; /* &main has no refresh block. */ /* This really is a bug. */ -#ifdef MultiThread - mainhead->program = &rootpstate; -#endif /* MultiThread */ -#if COMPILER - mainhead->file_name = ""; - mainhead->line_num = 0; -#endif /* COMPILER */ - -#ifdef Coexpr Protect(mainhead->es_actstk = alcactiv(), fatalerr(0,NULL)); pushact(mainhead, mainhead); -#endif /* Coexpr */ /* * Point &main at the co-expression block for the main procedure and set @@ -514,7 +334,6 @@ struct header *hdr; BlkLoc(k_main) = (union block *) mainhead; k_current = k_main; -#if !COMPILER /* * Read the interpretable code and data into memory. */ @@ -526,37 +345,26 @@ struct header *hdr; } fclose(fname); if (delete_icode) /* delete icode file if flag set earlier */ - remove(name); + remove(itval); -/* - * Make sure the version number of the icode matches the interpreter version. - */ + /* + * Make sure the version number of the icode matches the interpreter version. + */ if (strcmp((char *)hdr.config,IVersion)) { fprintf(stderr,"icode version mismatch in %s\n", name); fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); fprintf(stderr,"\texpected version: %s\n",IVersion); error(name, "cannot run"); } -#endif /* !COMPILER */ /* * Initialize the event monitoring system, if configured. */ -#ifdef EventMon - EVInit(); -#endif /* EventMon */ - -#if !COMPILER /* * Resolve references from icode to run-time system. */ -#ifdef MultiThread - resolve(NULL); -#else /* MultiThread */ resolve(); -#endif /* MultiThread */ -#endif /* COMPILER */ /* * Allocate and assign a buffer to stderr if possible. @@ -723,17 +531,13 @@ char *s; { fprintf(stderr, "System error"); if (pfp == NULL) - fprintf(stderr, " in startup code"); + fprintf(stderr, " in startup code\n"); else { -#if COMPILER - if (line_info) - fprintf(stderr, " at line %d in %s", line_num, file_name); -#else /* COMPILER */ - fprintf(stderr, " at line %ld in %s", (long)findline(ipc.opnd), + fprintf(stderr, " at line %ld in %s\n", (long)findline(ipc.opnd), findfile(ipc.opnd)); -#endif /* COMPILER */ } - fprintf(stderr, "\n%s\n", s); + if (s != NULL) + fprintf(stderr, "%s\n", s); fflush(stderr); if (dodump) abort(); @@ -747,35 +551,6 @@ void c_exit(i) int i; { -#ifdef EventMon - if (curpstate != NULL) { - EVVal((word)i, E_Exit); - } -#endif /* EventMon */ - -#ifdef MultiThread - if (curpstate != NULL && curpstate->parent != NULL) { - /* might want to get to the lterm somehow, instead */ - while (1) { - struct descrip dummy; - co_chng(curpstate->parent->Mainhead, NULL, &dummy, A_Cofail, 1); - } - } -#endif /* MultiThread */ - -#ifdef TallyOpt - { - int j; - - if (tallyopt) { - fprintf(stderr,"tallies: "); - for (j=0; j<16; j++) - fprintf(stderr," %ld", (long)tallybin[j]); - fprintf(stderr,"\n"); - } - } -#endif /* TallyOpt */ - if (k_dump && ixinited) { fprintf(stderr,"\nTermination dump:\n\n"); fflush(stderr); @@ -832,12 +607,6 @@ void datainit() * some compilers). [[I?]] */ -#ifdef MultiThread - k_errout.title = T_File; - k_input.title = T_File; - k_output.title = T_File; -#endif /* MultiThread */ - k_errout.fd = stderr; StrLen(k_errout.fname) = 7; StrLoc(k_errout.fname) = "&errout"; @@ -888,214 +657,11 @@ void datainit() StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; IntVal(zerodesc) = 0; -#ifdef EventMon -/* - * Initialization needed for event monitoring - */ - - BlkLoc(csetdesc) = (union block *)&fullcs; - BlkLoc(rzerodesc) = (union block *)&realzero; - -#endif /* EventMon */ - maps2 = nulldesc; maps3 = nulldesc; - #if !COMPILER - qsort((char *)pntab,pnsize,sizeof(struct pstrnm), (int(*)())pstrnmcmp); - #endif /* COMPILER */ - - } - -#ifdef MultiThread -/* - * loadicode - initialize memory particular to a given icode file - */ -struct b_coexpr * loadicode(name, theInput, theOutput, theError, bs, ss, stk) -char *name; -struct b_file *theInput, *theOutput, *theError; -C_integer bs, ss, stk; - { - struct b_coexpr *coexp; - struct progstate *pstate; - struct header hdr; - FILE *fname = NULL; - word cbread, longread(); - - /* - * open the icode file and read the header - */ - fname = readhdr(name,&hdr); - if (fname == NULL) - return NULL; - - /* - * Allocate memory for icode and the struct that describes it - */ - Protect(coexp = alccoexp(hdr.hsize, stk), - { fprintf(stderr,"can't malloc new icode region\n");c_exit(EXIT_FAILURE);}); - - pstate = coexp->program; - /* - * Initialize values. - */ - pstate->hsize = hdr.hsize; - pstate->parent= NULL; - pstate->parentdesc= nulldesc; - pstate->opcodemask= nulldesc; - pstate->eventmask= nulldesc; - pstate->eventcode= nulldesc; - pstate->eventval = nulldesc; - pstate->eventsource = nulldesc; - pstate->K_current.dword = D_Coexpr; - - MakeInt(0, &(pstate->Kywd_err)); - MakeInt(1, &(pstate->Kywd_pos)); - MakeInt(0, &(pstate->Kywd_ran)); - - StrLen(pstate->Kywd_prog) = strlen(prog_name); - StrLoc(pstate->Kywd_prog) = prog_name; - StrLen(pstate->ksub) = 0; - StrLoc(pstate->ksub) = ""; - MakeInt(hdr.trace, &(pstate->Kywd_trc)); - -#ifdef EventMon - pstate->Linenum = pstate->Column = pstate->Lastline = pstate->Lastcol = 0; -#endif /* EventMon */ - pstate->Lastop = 0; - /* - * might want to override from TRACE environment variable here. - */ - - /* - * Establish pointers to icode data regions. [[I?]] - */ - pstate->Mainhead= ((struct b_coexpr *)pstate)-1; - pstate->K_main.dword = D_Coexpr; - BlkLoc(pstate->K_main) = (union block *) pstate->Mainhead; - pstate->Code = (char *)(pstate + 1); - pstate->Ecode = (char *)(pstate->Code + hdr.Records); - pstate->Records = (word *)(pstate->Code + hdr.Records); - pstate->Ftabp = (int *)(pstate->Code + hdr.Ftab); -#ifdef FieldTableCompression - pstate->Fo = (int *)(pstate->Code + hdr.Fo); - pstate->Focp = (unsigned char *)(pstate->Fo); - pstate->Fosp = (short *)(pstate->Fo); - pstate->Foffwidth = hdr.FoffWidth; - if (hdr.FoffWidth == 1) { - pstate->Bm = (char *)(pstate->Focp + hdr.Nfields); - } - else if (hdr.FoffWidth == 2) { - pstate->Bm = (char *)(pstate->Fosp + hdr.Nfields); - } - else - pstate->Bm = (char *)(pstate->Fo + hdr.Nfields); - pstate->Ftabwidth= hdr.FtabWidth; - pstate->Foffwidth = hdr.FoffWidth; - pstate->Ftabcp = (unsigned char *)(pstate->Code + hdr.Ftab); - pstate->Ftabsp = (short *)(pstate->Code + hdr.Ftab); -#endif /* FieldTableCompression */ - pstate->Fnames = (dptr)(pstate->Code + hdr.Fnames); - pstate->Globals = pstate->Efnames = (dptr)(pstate->Code + hdr.Globals); - pstate->Gnames = pstate->Eglobals = (dptr)(pstate->Code + hdr.Gnames); - pstate->NGlobals = pstate->Eglobals - pstate->Globals; - pstate->Statics = pstate->Egnames = (dptr)(pstate->Code + hdr.Statics); - pstate->Estatics = (dptr)(pstate->Code + hdr.Filenms); - pstate->NStatics = pstate->Estatics - pstate->Statics; - pstate->Filenms = (struct ipc_fname *)(pstate->Estatics); - pstate->Efilenms = (struct ipc_fname *)(pstate->Code + hdr.linenums); - pstate->Ilines = (struct ipc_line *)(pstate->Efilenms); - pstate->Elines = (struct ipc_line *)(pstate->Code + hdr.Strcons); - pstate->Strcons = (char *)(pstate->Elines); - pstate->K_errornumber = 0; - pstate->T_errornumber = 0; - pstate->Have_errval = 0; - pstate->T_have_val = 0; - pstate->K_errortext = ""; - pstate->K_errorvalue = nulldesc; - pstate->T_errorvalue = nulldesc; - -#ifdef Graphics - MakeInt(0, &(pstate->AmperX)); - MakeInt(0, &(pstate->AmperY)); - MakeInt(0, &(pstate->AmperRow)); - MakeInt(0, &(pstate->AmperCol)); - MakeInt(0, &(pstate->AmperInterval)); - pstate->LastEventWin = nulldesc; - pstate->Kywd_xwin[XKey_Window] = nulldesc; -#endif /* Graphics */ - - pstate->Coexp_ser = 2; - pstate->List_ser = 1; - pstate->Set_ser = 1; - pstate->Table_ser = 1; - - pstate->stringtotal = pstate->blocktotal = - pstate->colltot = pstate->collstat = - pstate->collstr = pstate->collblk = 0; - - pstate->stringregion = (struct region *)malloc(sizeof(struct region)); - pstate->blockregion = (struct region *)malloc(sizeof(struct region)); - pstate->stringregion->size = ss; - pstate->blockregion->size = bs; - - /* - * the local program region list starts out with this region only - */ - pstate->stringregion->prev = NULL; - pstate->blockregion->prev = NULL; - pstate->stringregion->next = NULL; - pstate->blockregion->next = NULL; - /* - * the global region list links this region with curpstate's - */ - pstate->stringregion->Gprev = curpstate->stringregion; - pstate->blockregion->Gprev = curpstate->blockregion; - pstate->stringregion->Gnext = curpstate->stringregion->Gnext; - pstate->blockregion->Gnext = curpstate->blockregion->Gnext; - if (curpstate->stringregion->Gnext) - curpstate->stringregion->Gnext->Gprev = pstate->stringregion; - curpstate->stringregion->Gnext = pstate->stringregion; - if (curpstate->blockregion->Gnext) - curpstate->blockregion->Gnext->Gprev = pstate->blockregion; - curpstate->blockregion->Gnext = pstate->blockregion; - initalloc(0, pstate); - - pstate->K_errout = *theError; - pstate->K_input = *theInput; - pstate->K_output = *theOutput; - - /* - * Read the interpretable code and data into memory. - */ - if ((cbread = longread(pstate->Code, sizeof(char), (long)hdr.hsize, fname)) - != hdr.hsize) { - fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n", - (long)hdr.hsize,(long)cbread); - error(name, "can't read interpreter code"); - } - fclose(fname); - - /* - * Make sure the version number of the icode matches the interpreter version - */ - if (strcmp((char *)hdr.config,IVersion)) { - fprintf(stderr,"icode version mismatch in %s\n", name); - fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); - fprintf(stderr,"\texpected version: %s\n",IVersion); - error(name, "cannot run"); - } - - /* - * Resolve references from icode to run-time system. - * The first program has this done in icon_init after - * initializing the event monitoring system. - */ - resolve(pstate); - - return coexp; + qsort((char *)pntab,pnsize,sizeof(struct pstrnm), (int(*)())pstrnmcmp); } -#endif /* MultiThread */ #ifdef WinGraphics static void MSStartup(HINSTANCE hInstance, HINSTANCE hPrevInstance) diff --git a/src/runtime/interp.r b/src/runtime/interp.r index c5fd713..6955b8f 100644 --- a/src/runtime/interp.r +++ b/src/runtime/interp.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: interp.r * The interpreter proper. @@ -8,20 +7,7 @@ extern fptr fncentry[]; - -/* - * Prototypes for static functions. - */ -#ifdef EventMon -static struct ef_marker *vanq_bound (struct ef_marker *efp_v, - struct gf_marker *gfp_v); -static void vanq_proc (struct ef_marker *efp_v, - struct gf_marker *gfp_v); -#endif /* EventMon */ - -#ifndef MultiThread word lastop; /* Last operator evaluated */ -#endif /* MultiThread */ /* * Istate variables. @@ -37,32 +23,17 @@ struct descrip eret_tmp; /* eret value during unwinding */ int coexp_act; /* last co-expression action */ -#ifndef MultiThread dptr xargp; word xnargs; -#endif /* MultiThread */ /* * Macros for use inside the main loop of the interpreter. */ -#ifdef EventMon -#define E_Misc -1 -#define E_Operator 0 -#define E_Function 1 -#endif /* EventMon */ - /* * Setup_Op sets things up for a call to the C function for an operator. - * InterpEVValD expands to nothing if EventMon is not defined. */ #begdef Setup_Op(nargs) -#ifdef EventMon - lastev = E_Operator; - value_tmp.dword = D_Proc; - value_tmp.vword.bptr = (union block *)&op_tbl[lastop - 1]; - InterpEVValD(&value_tmp, E_Ocall); -#endif /* EventMon */ rargp = (dptr)(rsp - 1) - nargs; xargp = rargp; ExInterp; @@ -74,9 +45,6 @@ word xnargs; * operators. */ #begdef Setup_Arg(nargs) -#ifdef EventMon - lastev = E_Misc; -#endif /* EventMon */ rargp = (dptr)(rsp - 1) - nargs; xargp = rargp; ExInterp; @@ -84,17 +52,10 @@ word xnargs; #begdef Call_Cond if ((*(optab[lastop]))(rargp) == A_Resume) { -#ifdef EventMon - InterpEVVal((word)-1, E_Ofail); -#endif /* EventMon */ goto efail_noev; } rsp = (word *) rargp + 1; -#ifdef EventMon - goto return_term; -#else /* EventMon */ break; -#endif /* EventMon */ #enddef /* Call_Cond */ /* @@ -169,20 +130,7 @@ dptr cargp; extern int (*optab[])(); extern int (*keytab[])(); struct b_proc *bproc; -#ifdef EventMon - int lastev = E_Misc; -#endif /* EventMon */ - -#ifdef TallyOpt - extern word tallybin[]; -#endif /* TallyOpt */ - -#ifdef EventMon - EVVal(fsig, E_Intcall); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. @@ -190,7 +138,6 @@ dptr cargp; if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(301, NULL); -#endif /* MultiThread */ #ifdef Polling if (!pollctr--) { @@ -203,18 +150,7 @@ dptr cargp; EntInterp; -#ifdef EventMon - switch (fsig) { - case G_Csusp: - case G_Fsusp: - case G_Osusp: - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, - (fsig == G_Fsusp)?E_Fsusp:(fsig == G_Osusp?E_Osusp:E_Bsusp)); -#else /* EventMon */ if (fsig == G_Csusp) { -#endif /* EventMon */ oldsp = rsp; @@ -256,96 +192,7 @@ dptr cargp; */ for (;;) { - -#ifdef EventMon - - /* - * Location change events are generated by checking to see if the opcode - * has changed indices in the "line number" (now line + column) table; - * "straight line" forward code does not require a binary search to find - * the new location; instead, a pointer is simply incremented. - * Further optimization here is planned. - */ - if (!is:null(curpstate->eventmask) && ( - Testb((word)E_Loc, curpstate->eventmask) || - Testb((word)E_Line, curpstate->eventmask) - )) { - - if (InRange(code, ipc.opnd, ecode)) { - uword ipc_offset = DiffPtrs((char *)ipc.opnd, (char *)code); - uword size; - word temp_no; - if (!current_line_ptr || - current_line_ptr->ipc > ipc_offset || - current_line_ptr[1].ipc <= ipc_offset) { -#ifdef LineCodes -#ifdef Polling - if (!pollctr--) { - ExInterp; - pollctr = pollevent(); - EntInterp; - if (pollctr == -1) fatalerr(141, NULL); - } -#endif /* Polling */ -#endif /* LineCodes */ - - - if(current_line_ptr && - current_line_ptr + 2 < elines && - current_line_ptr[1].ipc < ipc_offset && - ipc_offset < current_line_ptr[2].ipc) { - current_line_ptr ++; - } - else { - current_line_ptr = ilines; - size = DiffPtrs((char *)elines, (char *)ilines) / - sizeof(struct ipc_line *); - while (size > 1) { - if (ipc_offset >= current_line_ptr[size>>1].ipc) { - current_line_ptr = ¤t_line_ptr[size>>1]; - size -= (size >> 1); - } - else { - size >>= 1; - } - } - } - linenum = current_line_ptr->line; - temp_no = linenum & 65535; - if ((lastline & 65535) != temp_no) { - if (Testb((word)E_Line, curpstate->eventmask)) - if (temp_no) - InterpEVVal(temp_no, E_Line); - } - if (lastline != linenum) { - lastline = linenum; - if (Testb((word)E_Loc, curpstate->eventmask) && - current_line_ptr->line >> 16) - InterpEVVal(current_line_ptr->line, E_Loc); - } - } - } - } -#endif /* EventMon */ - lastop = GetOp; /* Instruction fetch */ - -#ifdef EventMon - /* - * If we've asked for ALL opcode events, or specifically for this one - * generate an MT-style event. - */ - if ((!is:null(curpstate->eventmask) && - Testb((word)E_Opcode, curpstate->eventmask)) && - (is:null(curpstate->opcodemask) || - Testb((word)lastop, curpstate->opcodemask))) { - ExInterp; - MakeInt(lastop, &(curpstate->parent->eventval)); - actparent(E_Opcode); - EntInterp - } -#endif /* EventMon */ - switch ((int)lastop) { /* * Switch on opcode. The cases are * organized roughly by functionality @@ -564,23 +411,12 @@ dptr cargp; if (pollctr == -1) fatalerr(141, NULL); } #endif /* Polling */ - - #endif /* LineCodes */ break; - case Op_Colm: /* source column number */ { -#ifdef EventMon - word loc; - column = GetWord; - loc = column; - loc <<= (WordBits >> 1); /* column in high-order part */ - loc += linenum; - InterpEVVal(loc, E_Loc); -#endif /* EventMon */ break; } @@ -595,15 +431,7 @@ dptr cargp; if (pollctr == -1) fatalerr(141, NULL); } #endif /* Polling */ - - #endif /* LineCodes */ - -#ifdef EventMon - linenum = GetWord; - lastline = linenum; -#endif /* EventMon */ - break; /* ---String Scanning--- */ @@ -639,7 +467,6 @@ dptr cargp; bp = BlkLoc(value_tmp); args = (int)bp->list.size; -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. * This does nothing for invocation in a co-expression other @@ -649,14 +476,9 @@ dptr cargp; ((char *)sp + args * sizeof(struct descrip) > (char *)stackend)) fatalerr(301, NULL); -#endif /* MultiThread */ for (bp = bp->list.listhead; -#ifdef ListFix - BlkType(bp) == T_Lelem; -#else /* ListFix */ - bp != NULL; -#endif /* ListFix */ + bp != NULL; bp = bp->lelem.listnext) { for (i = 0; i < bp->lelem.nused; i++) { j = bp->lelem.first + i; @@ -719,52 +541,20 @@ invokej: } #endif /* Polling */ -#ifdef EventMon - lastev = E_Function; - InterpEVValD(rargp, E_Fcall); -#endif /* EventMon */ - bproc = (struct b_proc *)BlkLoc(*rargp); -#ifdef FncTrace - typedef int (*bfunc2)(dptr, struct descrip *); -#endif /* FncTrace */ - - /* ExInterp not needed since no change since last EntInterp */ if (type == I_Vararg) { int (*bfunc)(); bfunc = bproc->entryp.ccode; - -#ifdef FncTrace - signal = (*bfunc)(nargs, rargp, &(procs->pname)); -#else /* FncTrace */ signal = (*bfunc)(nargs,rargp); -#endif /* FncTrace */ - } else { int (*bfunc)(); bfunc = bproc->entryp.ccode; - -#ifdef FncTrace - signal = (*(bfunc2)bfunc)(rargp, &(bproc->pname)); -#else /* FncTrace */ signal = (*bfunc)(rargp); -#endif /* FncTrace */ - } - -#ifdef FncTrace - if (k_ftrace) { - k_ftrace--; - if (signal == A_Failure) - failtrace(&(bproc->pname)); - else - rtrace(&(bproc->pname),rargp); } -#endif /* FncTrace */ - goto C_rtn_term; } } @@ -781,19 +571,7 @@ invokej: case Op_Llist: /* construct list */ opnd = GetWord; - -#ifdef EventMon - lastev = E_Operator; - value_tmp.dword = D_Proc; - value_tmp.vword.bptr = (union block *)&mt_llist; - InterpEVValD(&value_tmp, E_Ocall); - rargp = (dptr)(rsp - 1) - opnd; - xargp = rargp; - ExInterp; -#else /* EventMon */ Setup_Arg(opnd); -#endif /* EventMon */ - { int i; for (i=1;i<=opnd;i++) @@ -840,13 +618,6 @@ mark0: break; case Op_Unmark: /* remove expression frame */ - -#ifdef EventMon - ExInterp; - vanq_bound(efp, gfp); - EntInterp; -#endif /* EventMon */ - gfp = efp->ef_gfp; rsp = (word *)efp - 1; @@ -858,12 +629,6 @@ Unmark_uw: --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Unmark_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Unmark_uw; } @@ -972,13 +737,6 @@ Unmark_uw: * limit not been reached). */ *lval = *(dptr)(rsp - 1); - -#ifdef EventMon - ExInterp; - vanq_bound(efp, gfp); - EntInterp; -#endif /* EventMon */ - gfp = efp->ef_gfp; /* @@ -989,12 +747,6 @@ Lsusp_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Lsusp_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Lsusp_uw; } rsp = (word *)efp - 1; @@ -1016,13 +768,6 @@ Lsusp_uw: struct descrip tmp; dptr svalp; struct b_proc *sproc; - -#ifdef EventMon - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, E_Psusp); -#endif /* EventMon */ - svalp = (dptr)(rsp - 1); if (Var(*svalp)) { ExInterp; @@ -1082,11 +827,6 @@ Lsusp_uw: * a saved state, switch environments. */ if (pfp->pf_scan != NULL) { - -#ifdef EventMon - InterpEVValD(&k_subject, E_Ssusp); -#endif /* EventMon */ - tmp = k_subject; k_subject = *pfp->pf_scan; *pfp->pf_scan = tmp; @@ -1096,14 +836,6 @@ Lsusp_uw: k_pos = IntVal(tmp); } -#ifdef MultiThread - /* - * If the program state changed for this procedure call, - * change back. - */ - ENTERPSTATE(pfp->pf_prog); -#endif /* MultiThread */ - efp = pfp->pf_efp; ipc = pfp->pf_ipc; glbl_argp = pfp->pf_argp; @@ -1132,12 +864,6 @@ Eret_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Eret_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Eret_uw; } rsp = (word *)efp - 1; @@ -1148,11 +874,6 @@ Eret_uw: case Op_Pret: { /* return from procedure */ -#ifdef EventMon - struct descrip oldargp; - static struct descrip unwinder; -#endif /* EventMon */ - /* * An Icon procedure is returning a value. Determine if the * value being returned should be dereferenced and if so, @@ -1163,14 +884,6 @@ Eret_uw: */ struct b_proc *rproc; rproc = (struct b_proc *)BlkLoc(*glbl_argp); -#ifdef EventMon - oldargp = *glbl_argp; - ExInterp; - vanq_proc(efp, gfp); - EntInterp; - /* used to InterpEVValD(argp,E_Pret); here */ -#endif /* EventMon */ - *glbl_argp = *(dptr)(rsp - 1); if (Var(*glbl_argp)) { ExInterp; @@ -1187,20 +900,9 @@ Pret_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Pret_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - unwinder = oldargp; -#endif /* EventMon */ - return A_Pret_uw; } -#ifdef EventMon - if (!is:proc(oldargp) && is:proc(unwinder)) - oldargp = unwinder; -#endif /* EventMon */ rsp = (word *)glbl_argp + 1; efp = pfp->pf_efp; gfp = pfp->pf_gfp; @@ -1208,15 +910,6 @@ Pret_uw: glbl_argp = pfp->pf_argp; pfp = pfp->pf_pfp; -#ifdef MultiThread - if (pfp) - ENTERPSTATE(pfp->pf_prog); -#ifdef EventMon - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, E_Pret); -#endif /* EventMon */ -#endif /* MultiThread */ break; } @@ -1224,9 +917,6 @@ Pret_uw: case Op_Efail: efail: -#ifdef EventMon - InterpEVVal((word)-1, E_Efail); -#endif /* EventMon */ efail_noev: /* * Failure has occurred in the current expression frame. @@ -1243,12 +933,6 @@ efail_noev: * structures that fail when complete. */ -#ifdef MultiThread - if (efp == 0) { - break; - } -#endif /* MultiThread */ - ipc = efp->ef_failure; gfp = efp->ef_gfp; rsp = (word *)efp - 1; @@ -1298,58 +982,22 @@ efail_noev: tmp = *(pfp->pf_scan + 1); IntVal(*(pfp->pf_scan + 1)) = k_pos; k_pos = IntVal(tmp); - -#ifdef EventMon - InterpEVValD(&k_subject, E_Sresum); -#endif /* EventMon */ } -#ifdef MultiThread - /* - * Enter the program state of the resumed frame - */ - ENTERPSTATE(pfp->pf_prog); -#endif /* MultiThread */ - ++k_level; /* adjust procedure level */ } switch (type) { -#ifdef EventMon - case G_Fsusp: - InterpEVVal((word)0, E_Fresum); - --ilevel; - ExInterp; - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - return A_Resume; - - case G_Osusp: - InterpEVVal((word)0, E_Oresum); - --ilevel; - ExInterp; - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - return A_Resume; -#endif /* EventMon */ - case G_Csusp: - InterpEVVal((word)0, E_Eresum); --ilevel; ExInterp; -#ifdef EventMon - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ return A_Resume; case G_Esusp: - InterpEVVal((word)0, E_Eresum); goto efail_noev; case G_Psusp: /* resuming a procedure */ - InterpEVValD(glbl_argp, E_Presum); break; } @@ -1357,14 +1005,6 @@ efail_noev: } case Op_Pfail: { /* fail from procedure */ - -#ifdef EventMon - ExInterp; - vanq_proc(efp, gfp); - EVValD(glbl_argp, E_Pfail); - EntInterp; -#endif /* EventMon */ - /* * An Icon procedure is failing. Generate tracing message if * tracing is on. Deactivate inactive C generators created @@ -1382,10 +1022,6 @@ Pfail_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; -#ifdef EventMon - EVVal(A_Pfail_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ return A_Pfail_uw; } efp = pfp->pf_efp; @@ -1393,17 +1029,6 @@ Pfail_uw: ipc = pfp->pf_ipc; glbl_argp = pfp->pf_argp; pfp = pfp->pf_pfp; - -#ifdef MultiThread - /* - * Enter the program state of the procedure being reentered. - * A NULL pfp indicates the program is complete. - */ - if (pfp) { - ENTERPSTATE(pfp->pf_prog); - } -#endif /* MultiThread */ - goto efail_noev; } /* ---Odds and Ends--- */ @@ -1478,12 +1103,6 @@ Pfail_uw: } goto mark0; -#ifdef TallyOpt - case Op_Tally: /* tally */ - tallybin[GetWord]++; - break; -#endif /* TallyOpt */ - case Op_Pnull: /* push null descriptor */ PushNull; break; @@ -1511,27 +1130,14 @@ Pfail_uw: /* ---Co-expressions--- */ case Op_Create: /* create */ - -#ifdef Coexpr PushNull; Setup_Arg(0); opnd = GetWord; opnd += (word)ipc.opnd; - signal = Ocreate((word *)opnd, rargp); - goto C_rtn_term; -#else /* Coexpr */ - err_msg(401, NULL); - goto efail; -#endif /* Coexpr */ case Op_Coact: { /* @e */ - -#ifndef Coexpr - err_msg(401, NULL); - goto efail; -#else /* Coexpr */ struct b_coexpr *ncp; dptr dp; @@ -1553,15 +1159,10 @@ Pfail_uw: goto efail_noev; else rsp -= 2; -#endif /* Coexpr */ break; } case Op_Coret: { /* return from co-expression */ - -#ifndef Coexpr - syserr("co-expression return, but co-expressions not implemented"); -#else /* Coexpr */ struct b_coexpr *ncp; ExInterp; @@ -1570,16 +1171,11 @@ Pfail_uw: ++BlkLoc(k_current)->coexpr.size; co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1); EntInterp; -#endif /* Coexpr */ break; } case Op_Cofail: { /* fail from co-expression */ - -#ifndef Coexpr - syserr("co-expression failure, but co-expressions not implemented"); -#else /* Coexpr */ struct b_coexpr *ncp; ExInterp; @@ -1587,7 +1183,6 @@ Pfail_uw: co_chng(ncp, NULL, NULL, A_Cofail, 1); EntInterp; -#endif /* Coexpr */ break; } @@ -1600,8 +1195,8 @@ Pfail_uw: default: { char buf[50]; - sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", - (long)lastop, lastop); + sprintf(buf, "unimplemented opcode: %ld (0x%08lx)\n", + (long)lastop, (long)lastop); syserr(buf); } } @@ -1613,73 +1208,25 @@ C_rtn_term: switch (signal) { case A_Resume: -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)-1, - ((lastev == E_Function)? E_Ffail : E_Ofail)); - lastev = E_Misc; - } -#endif /* EventMon */ goto efail_noev; case A_Unmark_uw: /* unwind for unmark */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Unmark_uw; case A_Lsusp_uw: /* unwind for lsusp */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Lsusp_uw; case A_Eret_uw: /* unwind for eret */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Eret_uw; case A_Pret_uw: /* unwind for pret */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Pret_uw; case A_Pfail_uw: /* unwind for pfail */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Pfail_uw; } rsp = (word *)rargp + 1; /* set rsp to result */ - -#ifdef EventMon -return_term: - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVValD(&value_tmp, ((lastev == E_Function) ? E_Fret:E_Oret)); - lastev = E_Misc; - } -#endif /* EventMon */ - continue; } @@ -1690,129 +1237,3 @@ interp_quit: /*NOTREACHED*/ return 0; /* avoid gcc warning */ } - -#ifdef EventMon -/* - * vanq_proc - monitor the removal of suspended operations from within - * a procedure. - */ -static void vanq_proc(efp_v, gfp_v) -struct ef_marker *efp_v; -struct gf_marker *gfp_v; - { - - if (is:null(curpstate->eventmask)) - return; - - /* - * Go through all the bounded expression of the procedure. - */ - while ((efp_v = vanq_bound(efp_v, gfp_v)) != NULL) { - gfp_v = efp_v->ef_gfp; - efp_v = efp_v->ef_efp; - } - } - -/* - * vanq_bound - monitor the removal of suspended operations from - * the current bounded expression and return the expression frame - * pointer for the bounded expression. - */ -static struct ef_marker *vanq_bound(efp_v, gfp_v) -struct ef_marker *efp_v; -struct gf_marker *gfp_v; - { - - if (is:null(curpstate->eventmask)) - return efp_v; - - while (gfp_v != 0) { /* note removal of suspended operations */ - switch ((int)gfp_v->gf_gentype) { - case G_Psusp: - EVValD(gfp_v->gf_argp, E_Prem); - break; - /* G_Fsusp and G_Osusp handled in-line during unwinding */ - case G_Esusp: - EVVal((word)0, E_Erem); - break; - } - - if (((int)gfp_v->gf_gentype) == G_Psusp) { - vanq_proc(gfp_v->gf_efp, gfp_v->gf_gfp); - efp_v = gfp_v->gf_pfp->pf_efp; /* efp before the call */ - gfp_v = gfp_v->gf_pfp->pf_gfp; /* gfp before the call */ - } - else { - efp_v = gfp_v->gf_efp; - gfp_v = gfp_v->gf_gfp; - } - } - - return efp_v; - } -#endif /* EventMon */ - -#ifdef MultiThread -/* - * activate some other co-expression from an arbitrary point in - * the interpreter. - */ -int mt_activate(tvalp,rslt,ncp) -dptr tvalp, rslt; -register struct b_coexpr *ncp; -{ - register struct b_coexpr *ccp = (struct b_coexpr *)BlkLoc(k_current); - int first, rv; - - dptr savedtvalloc = NULL; - /* - * Set activator in new co-expression. - */ - if (ncp->es_actstk == NULL) { - Protect(ncp->es_actstk = alcactiv(), { err_msg(0, NULL); exit(1); }); - /* - * If no one ever explicitly activates this co-expression, fail to - * the implicit activator. - */ - ncp->es_actstk->arec[0].activator = ccp; - first = 0; - } - else - first = 1; - - if(ccp->tvalloc) { - if (InRange(blkbase,ccp->tvalloc,blkfree)) { - fprintf(stderr, - "Multiprogram garbage collection disaster in mt_activate()!\n"); - fflush(stderr); - exit(1); - } - savedtvalloc = ccp->tvalloc; - } - - rv = co_chng(ncp, tvalp, rslt, A_MTEvent, first); - - if ((savedtvalloc != NULL) && (savedtvalloc != ccp->tvalloc)) { - fprintf(stderr,"averted co-expression disaster in activate\n"); - ccp->tvalloc = savedtvalloc; - } - - return rv; -} - - -/* - * activate the "&parent" co-expression from anywhere, if there is one - */ -void actparent(event) -int event; - { - struct progstate *parent = curpstate->parent; - - StrLen(parent->eventcode) = 1; - StrLoc(parent->eventcode) = (char *)&allchars[event & 0xFF]; - mt_activate(&(parent->eventcode), NULL, - (struct b_coexpr *)curpstate->parent->Mainhead); - } -#endif /* MultiThread */ -#endif /* !COMPILER */ diff --git a/src/runtime/invoke.r b/src/runtime/invoke.r index 87b9fd1..ab781af 100644 --- a/src/runtime/invoke.r +++ b/src/runtime/invoke.r @@ -1,148 +1,7 @@ /* - * invoke.r - contains invoke, apply + * invoke.r -- Perform setup for invocation. */ -#if COMPILER - -/* - * invoke - perform general invocation on a value. - */ -int invoke(nargs, args, rslt, succ_cont) -int nargs; -dptr args; -dptr rslt; -continuation succ_cont; - { - tended struct descrip callee; - struct b_proc *proc; - C_integer n; - - /* - * remove the operation being called from the argument list. - */ - deref(&args[0], &callee); - ++args; - nargs -= 1; - - if (is:proc(callee)) - return (*((struct b_proc *)BlkLoc(callee))->ccode)(nargs, args, rslt, - succ_cont); - else if (cnv:C_integer(callee, n)) { - if (n <= 0) - n += nargs + 1; - if (n <= 0 || n > nargs) - return A_Resume; - *rslt = args[n - 1]; - return A_Continue; - } - else if (cnv:string(callee, callee)) { - proc = strprc(&callee, (C_integer)nargs); - if (proc == NULL) - RunErr(106, &callee); - return (*(proc)->ccode)(nargs, args, rslt, succ_cont); - } - else - RunErr(106, &callee); - } - - -/* - * apply - implement binary bang. Construct an argument list for - * invoke() from the callee and the list it is applied to. - */ -int apply(callee, strct, rslt, succ_cont) -dptr callee; -dptr strct; -dptr rslt; -continuation succ_cont; - { - tended struct descrip dstrct; - struct tend_desc *tnd_args; /* place to tend arguments to invoke() */ - union block *ep; - int nargs; - word i, j; - word indx; - int signal; - - deref(strct, &dstrct); - - switch (Type(dstrct)) { - - case T_List: { - /* - * Copy the arguments from the list into an tended array of descriptors. - */ - nargs = BlkLoc(dstrct)->list.size + 1; - tnd_args = malloc(sizeof(struct tend_desc) - + (nargs - 1) * sizeof(struct descrip)); - if (tnd_args == NULL) - RunErr(305, NULL); - - tnd_args->d[0] = *callee; - indx = 1; - for (ep = BlkLoc(dstrct)->list.listhead; -#ifdef ListFix - BlkType(ep) == T_Lelem; -#else /* ListFix */ - ep != NULL; -#endif /* ListFix */ - ep = ep->lelem.listnext) { - for (i = 0; i < ep->lelem.nused; i++) { - j = ep->lelem.first + i; - if (j >= ep->lelem.nslots) - j -= ep->lelem.nslots; - tnd_args->d[indx++] = ep->lelem.lslots[j]; - } - } - tnd_args->num = nargs; - tnd_args->previous = tend; - tend = tnd_args; - - signal = invoke(indx, tnd_args->d, rslt, succ_cont); - - tend = tnd_args->previous; - free(tnd_args); - return signal; - } - case T_Record: { - /* - * Copy the arguments from the record into an tended array - * of descriptors. - */ - nargs = BlkLoc(dstrct)->record.recdesc->proc.nfields; - tnd_args = malloc(sizeof(struct tend_desc) - + (nargs - 1) * sizeof(struct descrip)); - if (tnd_args == NULL) - RunErr(305, NULL); - - tnd_args->d[0] = *callee; - indx = 1; - ep = BlkLoc(dstrct); - for (i = 0; i < nargs; i++) - tnd_args->d[indx++] = ep->record.fields[i]; - tnd_args->num = nargs; - tnd_args->previous = tend; - tend = tnd_args; - - signal = invoke(indx, tnd_args->d, rslt, succ_cont); - - tend = tnd_args->previous; - free(tnd_args); - return signal; - } - default: { - RunErr(126, &dstrct); - } - } - } - -#else /* COMPILER */ - -#ifdef EventMon -#include "../h/opdefs.h" -#endif /* EventMon */ - - /* * invoke -- Perform setup for invocation. */ @@ -294,15 +153,12 @@ int nargs, *n; *cargp = newargp; sp = newsp; - EVVal((word)Op_Invoke,E_Ecall); - if ((nparam < 0) || (proc->ndynam == -2)) return I_Vararg; else return I_Builtin; } -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. @@ -310,7 +166,6 @@ int nargs, *n; if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(301, NULL); -#endif /* MultiThread */ /* * Build the procedure frame. @@ -326,10 +181,6 @@ int nargs, *n; newpfp->pf_gfp = gfp; newpfp->pf_efp = efp; -#ifdef MultiThread - newpfp->pf_prog = curpstate; -#endif /* MultiThread */ - glbl_argp = newargp; pfp = newpfp; newsp += Vwsizeof(*pfp); @@ -347,15 +198,6 @@ int nargs, *n; */ ipc.opnd = (word *)proc->entryp.icode; -#ifdef MultiThread - /* - * Enter the program state of the procedure being invoked. - */ - if (!InRange(code, ipc.opnd, ecode)) { - syserr("interprogram procedure calls temporarily prohibited\n"); - } -#endif /* MultiThread */ - efp = 0; gfp = 0; @@ -369,9 +211,5 @@ int nargs, *n; sp = newsp; k_level++; - EVValD(newargp, E_Pcall); - return I_Continue; } - -#endif /* COMPILER */ diff --git a/src/runtime/keyword.r b/src/runtime/keyword.r index e6eb462..9e92607 100644 --- a/src/runtime/keyword.r +++ b/src/runtime/keyword.r @@ -55,25 +55,15 @@ keyword{4} collections } end -#if !COMPILER "&column - source column number of current execution point" keyword{1} column abstract { return integer; } inline { -#ifdef MultiThread -#ifdef EventMon - return C_integer findcol(ipc.opnd); -#else /* EventMon */ fail; -#endif /* EventMon */ -#else - fail; -#endif /* MultiThread */ } end -#endif /* !COMPILER */ "¤t - the currently active co-expression" keyword{1} current @@ -259,11 +249,7 @@ keyword{1,*} features return string } body { -#if COMPILER -#define Feature(guard,sym,kwval) if ((guard) && (kwval)) suspend C_string kwval; -#else /* COMPILER */ #define Feature(guard,sym,kwval) if (kwval) suspend C_string kwval; -#endif /* COMPILER */ #include "../h/features.h" fail; } @@ -275,17 +261,10 @@ keyword{1} file return string } inline { -#if COMPILER - if (line_info) - return C_string file_name; - else - runerr(402); -#else /* COMPILER */ char *s; s = findfile(ipc.opnd); if (!strcmp(s,"?")) fail; return C_string s; -#endif /* COMPILER */ } end @@ -332,10 +311,6 @@ keyword{1} level } inline { -#if COMPILER - if (!debug_info) - runerr(402); -#endif /* COMPILER */ return C_integer k_level; } end @@ -346,14 +321,7 @@ keyword{1} line return integer; } inline { -#if COMPILER - if (line_info) - return C_integer line_num; - else - runerr(402); -#else /* COMPILER */ return C_integer findline(ipc.opnd); -#endif /* COMPILER */ } end @@ -460,11 +428,7 @@ keyword{1} source return coexpr } inline { -#ifndef Coexpr - return k_main; -#else /* Coexpr */ return coexpr(topact((struct b_coexpr *)BlkLoc(k_current))); -#endif /* Coexpr */ } end @@ -545,9 +509,7 @@ keyword{1} version constant Version end -#ifndef MultiThread struct descrip kywd_xwin[2] = {{D_Null}}; -#endif /* MultiThread */ "&window - variable containing the current graphics rendering context." #ifdef Graphics diff --git a/src/runtime/lmisc.r b/src/runtime/lmisc.r index 11f29de..52f0a6d 100644 --- a/src/runtime/lmisc.r +++ b/src/runtime/lmisc.r @@ -6,86 +6,48 @@ /* * create - return an entry block for a co-expression. */ -#if COMPILER -struct b_coexpr *create(fnc, cproc, ntemps, wrk_size) -continuation fnc; -struct b_proc *cproc; -int ntemps; -int wrk_size; -#else /* COMPILER */ int Ocreate(entryp, cargp) word *entryp; register dptr cargp; -#endif /* COMPILER */ { - -#ifdef Coexpr tended struct b_coexpr *sblkp; register struct b_refresh *rblkp; register dptr dp, ndp; int na, nl, i; - -#if !COMPILER struct b_proc *cproc; /* cproc is the Icon procedure that create occurs in */ cproc = (struct b_proc *)BlkLoc(glbl_argp[0]); -#endif /* COMPILER */ /* * Calculate number of arguments and number of local variables. */ -#if COMPILER - na = abs((int)cproc->nparam); -#else /* COMPILER */ na = pfp->pf_nargs + 1; /* includes Arg0 */ -#endif /* COMPILER */ nl = (int)cproc->ndynam; /* * Get a new co-expression stack and initialize. */ - -#ifdef MultiThread - Protect(sblkp = alccoexp(0, 0), err_msg(0, NULL)); -#else /* MultiThread */ Protect(sblkp = alccoexp(), err_msg(0, NULL)); -#endif /* MultiThread */ - - if (!sblkp) -#if COMPILER - return NULL; -#else /* COMPILER */ Fail; -#endif /* COMPILER */ /* * Get a refresh block for the new co-expression. */ -#if COMPILER - Protect(rblkp = alcrefresh(na, nl, ntemps, wrk_size), err_msg(0,NULL)); -#else /* COMPILER */ Protect(rblkp = alcrefresh(entryp, na, nl),err_msg(0,NULL)); -#endif /* COMPILER */ if (!rblkp) -#if COMPILER - return NULL; -#else /* COMPILER */ Fail; -#endif /* COMPILER */ sblkp->freshblk.dword = D_Refresh; BlkLoc(sblkp->freshblk) = (union block *) rblkp; -#if !COMPILER /* * Copy current procedure frame marker into refresh block. */ rblkp->pfmkr = *pfp; rblkp->pfmkr.pf_pfp = 0; -#endif /* COMPILER */ /* * Copy arguments into refresh block. @@ -98,11 +60,7 @@ register dptr cargp; /* * Copy locals into the refresh block. */ -#if COMPILER - dp = pfp->tend.d; -#else /* COMPILER */ dp = &(pfp->pf_locals)[0]; -#endif /* COMPILER */ for (i = 1; i <= nl; i++) *ndp++ = *dp++; @@ -111,33 +69,12 @@ register dptr cargp; */ co_init(sblkp); -#if COMPILER - sblkp->fnc = fnc; - if (line_info) { - if (debug_info) - PFDebug(sblkp->pf)->proc = cproc; - PFDebug(sblkp->pf)->old_fname = ""; - PFDebug(sblkp->pf)->old_line = 0; - } - - return sblkp; -#else /* COMPILER */ /* * Return the new co-expression. */ Arg0.dword = D_Coexpr; BlkLoc(Arg0) = (union block *) sblkp; Return; -#endif /* COMPILER */ -#else /* Coexpr */ - err_msg(401, NULL); -#if COMPILER - return NULL; -#else /* COMPILER */ - Fail; -#endif /* COMPILER */ -#endif /* Coexpr */ - } /* @@ -148,8 +85,6 @@ dptr val; struct b_coexpr *ncp; dptr result; { -#ifdef Coexpr - int first; /* @@ -169,8 +104,4 @@ dptr result; return A_Resume; else return A_Continue; - -#else /* Coexpr */ - RunErr(401,NULL); -#endif /* Coexpr */ } diff --git a/src/runtime/oarith.r b/src/runtime/oarith.r index b3ca88c..7d0978f 100644 --- a/src/runtime/oarith.r +++ b/src/runtime/oarith.r @@ -13,9 +13,7 @@ int over_flow = 0; operator{1} icon_op func_name(x, y) declare { -#ifdef LargeInts tended struct descrip lx, ly; -#endif /* LargeInts */ C_integer irslt; } arith_case (x, y) of { @@ -70,15 +68,11 @@ end irslt = div3(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigdiv(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; } @@ -112,15 +106,11 @@ ArithOp( / , divide , Divide , RealDivide) #begdef Sub(x,y) irslt = sub(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigsub(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -196,15 +186,11 @@ ArithOp( % , mod , IntMod , RealMod) #begdef Mpy(x,y) irslt = mul(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigmul(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -228,21 +214,15 @@ operator{1} - neg(x) i = neg(x); if (over_flow) { -#ifdef LargeInts struct descrip tmp; MakeInt(x,&tmp); if (bigneg(&tmp, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - irunerr(203,x); - errorfail; -#endif /* LargeInts */ } return C_integer i; } } -#ifdef LargeInts else if cnv:(exact) integer(x) then { abstract { return integer @@ -253,7 +233,6 @@ operator{1} - neg(x) return result; } } -#endif /* LargeInts */ else { if !cnv:C_double(x) then runerr(102, x) @@ -282,7 +261,6 @@ operator{1} + number(x) return C_integer x; } } -#ifdef LargeInts else if cnv:(exact) integer(x) then { abstract { return integer @@ -291,7 +269,6 @@ operator{1} + number(x) return x; } } -#endif /* LargeInts */ else if cnv:C_double(x) then { abstract { return real @@ -319,15 +296,11 @@ end #begdef Add(x,y) irslt = add(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigadd(&lx, &ly, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -346,19 +319,11 @@ operator{1} ^ powr(x, y) return integer } inline { -#ifdef LargeInts tended struct descrip ly; MakeInt ( y, &ly ); if (bigpow(&x, &ly, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else - extern int over_flow; - C_integer r = iipow(IntVal(x), y); - if (over_flow) - runerr(203); - return C_integer r; -#endif } } else { @@ -374,7 +339,6 @@ operator{1} ^ powr(x, y) } } } -#ifdef LargeInts else if cnv:(exact)integer(y) then { if cnv:(exact)integer(x) then { abstract { @@ -399,7 +363,6 @@ operator{1} ^ powr(x, y) } } } -#endif /* LargeInts */ else { if !cnv:C_double(x) then runerr(102, x) @@ -418,52 +381,6 @@ operator{1} ^ powr(x, y) } end -#if COMPILER || !(defined LargeInts) -/* - * iipow - raise an integer to an integral power. - */ -C_integer iipow(n1, n2) -C_integer n1, n2; - { - C_integer result; - - /* Handle some special cases first */ - over_flow = 0; - switch ( n1 ) { - case 1: - return 1; - case -1: - /* Result depends on whether n2 is even or odd */ - return ( n2 & 01 ) ? -1 : 1; - case 0: - if ( n2 <= 0 ) - over_flow = 1; - return 0; - default: - if (n2 < 0) - return 0; - } - - result = 1L; - for ( ; ; ) { - if (n2 & 01L) - { - result = mul(result, n1); - if (over_flow) - return 0; - } - - if ( ( n2 >>= 1 ) == 0 ) break; - n1 = mul(n1, n1); - if (over_flow) - return 0; - } - over_flow = 0; - return result; - } -#endif /* COMPILER || !(defined LargeInts) */ - - /* * ripow - raise a real number to an integral power. */ diff --git a/src/runtime/oasgn.r b/src/runtime/oasgn.r index b93d646..0b25c1d 100644 --- a/src/runtime/oasgn.r +++ b/src/runtime/oasgn.r @@ -14,15 +14,6 @@ */ #begdef GeneralAsgn(x, y) -#ifdef EventMon - body { - if (!is:null(curpstate->eventmask) && - Testb((word)E_Assign, curpstate->eventmask)) { - EVAsgn(&x); - } - } -#endif /* EventMon */ - type_case x of { tvsubs: { abstract { @@ -85,18 +76,10 @@ if (!cnv:C_integer(y, i)) runerr(101, y); - -#ifdef MultiThread - i = cvpos((long)i, StrLen(*(VarLoc(x)+1))); -#else /* MultiThread */ i = cvpos((long)i, StrLen(k_subject)); -#endif /* MultiThread */ - if (i == CvtFail) fail; IntVal(*VarLoc(x)) = i; - - EVVal(k_pos, E_Spos); } } kywdsubj: { @@ -107,12 +90,7 @@ if !cnv:string(y, *VarLoc(x)) then runerr(103, y); inline { -#ifdef MultiThread - IntVal(*(VarLoc(x)-1)) = 1; -#else /* MultiThread */ k_pos = 1; -#endif /* MultiThread */ - EVVal(k_pos, E_Spos); } } kywdstr: { @@ -132,12 +110,6 @@ } } -#ifdef EventMon - body { - EVValD(&y, E_Value); - } -#endif /* EventMon */ - #enddef @@ -460,8 +432,6 @@ const dptr src; } } tvsub->sslen = StrLen(srcstr); - - EVVal(tvsub->sslen, E_Ssasgn); return Succeeded; } diff --git a/src/runtime/ocat.r b/src/runtime/ocat.r index c778d6d..80f0e82 100644 --- a/src/runtime/ocat.r +++ b/src/runtime/ocat.r @@ -101,9 +101,6 @@ operator{1} ||| lconcat(x, y) Protect(bp1 = (struct b_list *)alclist(size3), runerr(0)); Protect(lp1 = (struct b_lelem *)alclstb(size3,(word)0,size3), runerr(0)); bp1->listhead = bp1->listtail = (union block *)lp1; -#ifdef ListFix - lp1->listprev = lp1->listnext = (union block *)bp1; -#endif /* ListFix */ /* * Make a copy of both lists in adjacent slots. @@ -112,9 +109,6 @@ operator{1} ||| lconcat(x, y) cpslots(&y, lp1->lslots + size1, (word)1, size2 + 1); BlkLoc(x) = (union block *)bp1; - - EVValD(&x, E_Lcreate); - return x; } end diff --git a/src/runtime/omisc.r b/src/runtime/omisc.r index 96a3e1b..4c11678 100644 --- a/src/runtime/omisc.r +++ b/src/runtime/omisc.r @@ -4,7 +4,6 @@ */ "^x - create a refreshed copy of a co-expression." -#ifdef Coexpr /* * ^x - return an entry block for co-expression x from the refresh block. */ @@ -21,12 +20,7 @@ operator{1} ^ refresh(x) /* * Get a new co-expression stack and initialize. */ -#ifdef MultiThread - Protect(sblkp = alccoexp(0, 0), runerr(0)); -#else /* MultiThread */ Protect(sblkp = alccoexp(), runerr(0)); -#endif /* MultiThread */ - sblkp->freshblk = BlkLoc(x)->coexpr.freshblk; if (ChkNull(sblkp->freshblk)) /* &main cannot be refreshed */ runerr(215, x); @@ -35,26 +29,8 @@ operator{1} ^ refresh(x) * Use refresh block to finish initializing the new co-expression. */ co_init(sblkp); - -#if COMPILER - sblkp->fnc = BlkLoc(x)->coexpr.fnc; - if (line_info) { - if (debug_info) - PFDebug(sblkp->pf)->proc = PFDebug(BlkLoc(x)->coexpr.pf)->proc; - PFDebug(sblkp->pf)->old_fname = - PFDebug(BlkLoc(x)->coexpr.pf)->old_fname; - PFDebug(sblkp->pf)->old_line = - PFDebug(BlkLoc(x)->coexpr.pf)->old_line; - } -#endif /* COMPILER */ - return coexpr(sblkp); } -#else /* Coexpr */ -operator{} ^ refresh(x) - runerr(401) -#endif /* Coexpr */ - end @@ -151,9 +127,6 @@ operator{*} = tabmat(x) */ l = StrLen(x); k_pos += l; - - EVVal(k_pos, E_Spos); - suspend x; /* @@ -161,10 +134,8 @@ operator{*} = tabmat(x) */ if (i > StrLen(k_subject) + 1) runerr(205, kywd_pos); - else { + else k_pos = i; - EVVal(k_pos, E_Spos); - } fail; } end @@ -265,9 +236,6 @@ operator{1} [...] llist(elems[n]) * for the list. */ hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ /* * Assign each argument to a list element. @@ -275,9 +243,6 @@ operator{1} [...] llist(elems[n]) for (i = 0; i < n; i++) bp->lslots[i] = elems[i]; -/* Not quite right -- should be after list() returns in case it fails */ - Desc_EVValD(hp, E_Lcreate, D_List); - return list(hp); } end diff --git a/src/runtime/oref.r b/src/runtime/oref.r index 3ac86bc..8e1ffea 100644 --- a/src/runtime/oref.r +++ b/src/runtime/oref.r @@ -38,35 +38,18 @@ operator{*} ! bang(underef x -> dx) return type(dx).lst_elem } inline { - -#ifdef EventMon - word xi = 0; - - EVValD(&dx, E_Lbang); -#endif /* EventMon */ - /* * x is a list. Chain through each list element block and for * each one, suspend with a variable pointing to each * element contained in the block. */ for (ep = BlkLoc(dx)->list.listhead; -#ifdef ListFix - BlkType(ep) == T_Lelem; -#else /* ListFix */ ep != NULL; -#endif /* ListFix */ ep = ep->lelem.listnext){ for (i = 0; i < ep->lelem.nused; i++) { j = ep->lelem.first + i; if (j >= ep->lelem.nslots) j -= ep->lelem.nslots; - -#ifdef EventMon - MakeInt(++xi, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - suspend struct_var(&ep->lelem.lslots[j], ep); } } @@ -158,17 +141,12 @@ operator{*} ! bang(underef x -> dx) inline { struct b_tvtbl *tp; - EVValD(&dx, E_Tbang); - /* * x is a table. Chain down the element list in each bucket * and suspend a variable pointing to each element in turn. */ for (ep = hgfirst(BlkLoc(dx), &state); ep != 0; ep = hgnext(BlkLoc(dx), &state, ep)) { - - EVValD(&ep->telem.tval, E_Tval); - Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0)); suspend tvtbl(tp); } @@ -180,14 +158,12 @@ operator{*} ! bang(underef x -> dx) return store[type(dx).set_elem] } inline { - EVValD(&dx, E_Sbang); /* * This is similar to the method for tables except that a * value is returned instead of a variable. */ for (ep = hgfirst(BlkLoc(dx), &state); ep != 0; ep = hgnext(BlkLoc(dx), &state, ep)) { - EVValD(&ep->selem.setmem, E_Sval); suspend ep->selem.setmem; } } @@ -202,21 +178,8 @@ operator{*} ! bang(underef x -> dx) * x is a record. Loop through the fields and suspend * a variable pointing to each one. */ - -#ifdef EventMon - word xi = 0; - - EVValD(&dx, E_Rbang); -#endif /* EventMon */ - j = BlkLoc(dx)->record.recdesc->proc.nfields; for (i = 0; i < j; i++) { - -#ifdef EventMon - MakeInt(++xi, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - suspend struct_var(&BlkLoc(dx)->record.fields[i], (struct b_record *)BlkLoc(dx)); } @@ -256,12 +219,6 @@ end operator{0,1} ? random(underef x -> dx) -#ifndef LargeInts - declare { - C_integer v = 0; - } -#endif /* LargeInts */ - if is:variable(x) && is:string(dx) then { abstract { return new tvsubs(type(x)) @@ -347,13 +304,6 @@ operator{0,1} ? random(underef x -> dx) rval = RandVal; rval *= val; i = (word)rval + 1; - -#ifdef EventMon - EVValD(&dx, E_Lrand); - MakeInt(i, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - j = 1; /* * Work down chain list of list blocks and find the block that @@ -363,11 +313,7 @@ operator{0,1} ? random(underef x -> dx) while (i >= j + bp->lelem.nused) { j += bp->lelem.nused; bp = bp->lelem.listnext; -#ifdef ListFix - if (BlkType(bp) == T_List) -#else /* ListFix */ if (bp == NULL) -#endif /* ListFix */ syserr("list reference out of bounds in random"); } /* @@ -405,13 +351,6 @@ operator{0,1} ? random(underef x -> dx) rval *= val; n = (word)rval + 1; -#ifdef EventMon - EVValD(&dx, E_Trand); - MakeInt(n, &eventdesc); - EVValD(&eventdesc, E_Tsub); -#endif /* EventMon */ - - /* * Walk down the hash chains to find and return the nth element * as a variable. @@ -419,11 +358,7 @@ operator{0,1} ? random(underef x -> dx) for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink) if (--n <= 0) { Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0)); @@ -456,11 +391,6 @@ operator{0,1} ? random(underef x -> dx) rval *= val; n = (word)rval + 1; -#ifdef EventMon - EVValD(&dx, E_Srand); - MakeInt(n, &eventdesc); -#endif /* EventMon */ - /* * Walk down the hash chains to find and return the nth element. */ @@ -497,43 +427,27 @@ operator{0,1} ? random(underef x -> dx) */ rval = RandVal; rval *= val; - -#ifdef EventMon - EVValD(&dx, E_Rrand); - MakeInt(rval + 1, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - return struct_var(&rec->fields[(word)rval], rec); } } default: { -#ifdef LargeInts if !cnv:integer(dx) then runerr(113, dx) -#else /* LargeInts */ - if !cnv:C_integer(dx,v) then - runerr(113, dx) -#endif /* LargeInts */ - abstract { return integer ++ real } body { double rval; - -#ifdef LargeInts C_integer v; if (Type(dx) == T_Lrgint) { if (bigrand(&dx, &result) == Error) /* alcbignum failed */ runerr(0); return result; } - v = IntVal(dx); -#endif /* LargeInts */ + /* * x is an integer, be sure that it's non-negative. */ @@ -690,12 +604,6 @@ operator{0,1} [] subsc(underef x -> dx,y) register union block *bp; /* doesn't need to be tended */ struct b_list *lp; /* doesn't need to be tended */ -#ifdef EventMon - EVValD(&dx, E_Lref); - MakeInt(y, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - /* * Make sure that subscript y is in range. */ @@ -742,9 +650,6 @@ operator{0,1} [] subsc(underef x -> dx,y) uword hn; struct b_tvtbl *tp; - EVValD(&dx, E_Tref); - EVValD(&y, E_Tsub); - hn = hash(&y); Protect(tp = alctvtbl(&dx, &y, hn), runerr(0)); return tvtbl(tp); @@ -777,13 +682,6 @@ operator{0,1} [] subsc(underef x -> dx,y) for(i=0; i<nf; i++) { if (len == StrLen(bp2->proc.lnames[i]) && !strncmp(loc, StrLoc(bp2->proc.lnames[i]), len)) { - -#ifdef EventMon - EVValD(&dx, E_Rref); - MakeInt(i+1, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - /* * Found the field, return a pointer to it. */ @@ -802,13 +700,6 @@ operator{0,1} [] subsc(underef x -> dx,y) i = cvpos(y, (word)(bp->record.recdesc->proc.nfields)); if (i == CvtFail || i > bp->record.recdesc->proc.nfields) fail; - -#ifdef EventMon - EVValD(&dx, E_Rref); - MakeInt(i, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - /* * Locate the appropriate field and return a pointer to it. */ diff --git a/src/runtime/oset.r b/src/runtime/oset.r index 7808e80..dc8e126 100644 --- a/src/runtime/oset.r +++ b/src/runtime/oset.r @@ -84,7 +84,6 @@ operator{1} -- diff(x,y) deallocate((union block *)np); if (TooSparse(dstp)) hshrink(dstp); - Desc_EVValD(dstp, E_Screate, D_Set); return set(dstp); } } @@ -175,7 +174,6 @@ operator{1} ** inter(x,y) deallocate((union block *)np); if (TooSparse(dstp)) hshrink(dstp); - Desc_EVValD(dstp, E_Screate, D_Set); return set(dstp); } } diff --git a/src/runtime/ralc.r b/src/runtime/ralc.r index 9f55671..403515b 100644 --- a/src/runtime/ralc.r +++ b/src/runtime/ralc.r @@ -11,12 +11,11 @@ static struct region *newregion (word nbytes, word stdsize); extern word alcnum; -#ifndef MultiThread word coexp_ser = 2; /* serial numbers for co-expressions; &main is 1 */ +word extl_ser = 1; /* serial numbers for externals */ word list_ser = 1; /* serial numbers for lists */ word set_ser = 1; /* serial numbers for sets */ word table_ser = 1; /* serial numbers for tables */ -#endif /* MultiThread */ /* @@ -24,10 +23,6 @@ word table_ser = 1; /* serial numbers for tables */ */ #begdef AlcBlk(var, struct_nm, t_code, nbytes) { -#ifdef MultiThread - EVVal((word)nbytes, typech[t_code]); -#endif /* MultiThread */ - /* * Ensure that there is enough room in the block region. */ @@ -35,13 +30,6 @@ word table_ser = 1; /* serial numbers for tables */ return NULL; /* - * If monitoring, show the allocation. - */ -#ifndef MultiThread - EVVal((word)nbytes, typech[t_code]); -#endif - - /* * Decrement the free space in the block region by the number of bytes * allocated and return the address of the first byte of the allocated * block. @@ -64,11 +52,7 @@ word table_ser = 1; /* serial numbers for tables */ */ #begdef AlcVarBlk(var, struct_nm, t_code, n_desc) { -#ifdef EventMon - uword size; -#else /* EventMon */ register uword size; -#endif /* EventMon */ /* * Variable size blocks are declared with one descriptor, thus @@ -105,7 +89,6 @@ struct astkblk *alcactiv() return abp; } -#ifdef LargeInts /* * alcbignum - allocate an n-digit bignum in the block region */ @@ -125,17 +108,18 @@ word n; blk->lsd = n - 1; return blk; } -#endif /* LargeInts */ /* * alccoexp - allocate a co-expression stack block. + * + * Although pthreads allocates a C stack, we still need this an + * interpreter stack beyond the end of the coexpr block. */ -#if COMPILER struct b_coexpr *alccoexp() { struct b_coexpr *ep; - static int serial = 2; /* main co-expression is allocated elsewhere */ + ep = (struct b_coexpr *)malloc(stksize); /* @@ -146,112 +130,24 @@ struct b_coexpr *alccoexp() if (ep == NULL || alcnum > AlcMax) { collect(Static); ep = (struct b_coexpr *)malloc(stksize); - } - + } if (ep == NULL) ReturnErrNum(305, NULL); - alcnum++; /* increment allocation count since last g.c. */ - - ep->title = T_Coexpr; - ep->size = 0; - ep->id = serial++; - ep->nextstk = stklist; - ep->es_tend = NULL; - ep->file_name = ""; - ep->line_num = 0; - ep->freshblk = nulldesc; - ep->es_actstk = NULL; - ep->cstate[0] = 0; /* zero the first two cstate words as a flag */ - ep->cstate[1] = 0; - stklist = ep; - return ep; - } -#else /* COMPILER */ -#ifdef MultiThread -/* - * If this is a new program being loaded, an icodesize>0 gives the - * hdr.hsize and a stacksize to use; allocate - * sizeof(progstate) + icodesize + mstksize - * Otherwise (icodesize==0), allocate a normal stksize... - */ -struct b_coexpr *alccoexp(icodesize, stacksize) -long icodesize, stacksize; -#else /* MultiThread */ -struct b_coexpr *alccoexp() -#endif /* MultiThread */ - - { - struct b_coexpr *ep; - -#ifdef MultiThread - if (icodesize > 0) { - ep = (struct b_coexpr *) - calloc(1, stacksize+ - icodesize+ - sizeof(struct progstate)+ - sizeof(struct b_coexpr)); - } - else -#endif /* MultiThread */ - - ep = (struct b_coexpr *)malloc(stksize); - - /* - * If malloc failed or if there have been too many co-expression allocations - * since a collection, attempt to free some co-expression blocks and retry. - */ - - if (ep == NULL || alcnum > AlcMax) { - - collect(Static); - -#ifdef MultiThread - if (icodesize>0) { - ep = (struct b_coexpr *) - malloc(mstksize+icodesize+sizeof(struct progstate)); - } - else -#endif /* MultiThread */ - - ep = (struct b_coexpr *)malloc(stksize); - } - if (ep == NULL) - ReturnErrNum(305, NULL); - alcnum++; /* increment allocation count since last g.c. */ ep->title = T_Coexpr; ep->es_actstk = NULL; ep->size = 0; -#ifdef MultiThread - ep->es_pfp = NULL; - ep->es_gfp = NULL; - ep->es_argp = NULL; - ep->tvalloc = NULL; - - if (icodesize > 0) - ep->id = 1; - else -#endif /* MultiThread */ ep->id = coexp_ser++; ep->nextstk = stklist; ep->es_tend = NULL; ep->cstate[0] = 0; /* zero the first two cstate words as a flag */ ep->cstate[1] = 0; -#ifdef MultiThread - /* - * Initialize program state to self for &main; curpstate for others. - */ - if(icodesize>0) ep->program = (struct progstate *)(ep+1); - else ep->program = curpstate; -#endif /* MultiThread */ - stklist = ep; return ep; } -#endif /* COMPILER */ /* * alccset - allocate a cset in the block region. @@ -274,6 +170,46 @@ struct b_cset *alccset() } /* + * alcexternal - allocate an external data block in the block region. + * + * nbytes is total struct size including header, or zero to use default + * f is dispatch table of user C functions; also differentiates external types + * data is copied in to initialize the data block. + * Any of these can be zero/null for default behavior. + * + * May cause a garbage collection. Returns null if still unsuccessful. + */ + +struct b_external *alcexternal(long nbytes, struct b_extlfuns *f, void *data) + { + register struct b_external *blk; + long datasize; + static struct b_extlfuns fdefault; /* default dispatch table, all empty */ + + if (nbytes == 0) + nbytes = sizeof(struct b_external); + + /* datasize = nbytes - offsetof(struct b_external, data); */ + datasize = nbytes - ((char*)blk->data - (char*)blk); + if (datasize < 0) + syserr("alcexternal: invalid size"); + + /* now, after calculating datasize, round up nbytes to a word multiple */ + nbytes = (nbytes + sizeof(word) - 1) & ~(sizeof(word) - 1); + + if (f == NULL) + f = &fdefault; + + AlcBlk(blk, b_external, T_External, nbytes); + blk->blksize = nbytes; + blk->id = extl_ser++; + blk->funcs = f; + if (data != NULL) + memcpy(blk->data, data, datasize); + return blk; + } + +/* * alcfile - allocate a file block in the block region. */ @@ -429,23 +365,6 @@ union block *recptr; * alcrefresh - allocate a co-expression refresh block. */ -#if COMPILER -struct b_refresh *alcrefresh(na, nl, nt, wrk_sz) -int na; -int nl; -int nt; -int wrk_sz; - { - struct b_refresh *blk; - - AlcVarBlk(blk, b_refresh, T_Refresh, na + nl) - blk->nlocals = nl; - blk->nargs = na; - blk->ntemps = nt; - blk->wrk_size = wrk_sz; - return blk; - } -#else /* COMPILER */ struct b_refresh *alcrefresh(entryx, na, nl) word *entryx; int na, nl; @@ -457,7 +376,6 @@ int na, nl; blk->numlocals = nl; return blk; } -#endif /* COMPILER */ /* * alcselem - allocate a set element block. @@ -490,16 +408,6 @@ register word slen; register char *d; char *ofree; -#ifdef MultiThread - StrLen(ts) = slen; - StrLoc(ts) = s; -#ifdef EventMon - if (!noMTevents) -#endif /* EventMon */ - EVVal(slen, E_String); - s = StrLoc(ts); -#endif /* MultiThread */ - /* * Make sure there is enough room in the string space. */ @@ -606,7 +514,6 @@ union block *bp; syserr ("deallocation botch"); rp->free = (char *)bp; blktotal -= nbytes; - EVVal(nbytes, E_BlkDeAlc); } /* @@ -691,16 +598,6 @@ word nbytes; if (curr->Gprev) curr->Gprev->Gnext = rp; curr->Gprev = rp; *pcurr = rp; -#ifdef EventMon - if (!noMTevents) { - if (region == Strings) { - EVVal(rp->size, E_TenureString); - } - else { - EVVal(rp->size, E_TenureBlock); - } - } -#endif /* EventMon */ return rp->free; } diff --git a/src/runtime/rcoexpr.r b/src/runtime/rcoexpr.r index 4036ef6..a613873 100644 --- a/src/runtime/rcoexpr.r +++ b/src/runtime/rcoexpr.r @@ -2,10 +2,6 @@ * File: rcoexpr.r -- co_init, co_chng */ -#if COMPILER -static continuation coexpr_fnc; /* function to call after switching stacks */ -#endif /* COMPILER */ - /* * co_init - use the contents of the refresh block to initialize the * co-expression. @@ -13,9 +9,6 @@ static continuation coexpr_fnc; /* function to call after switching stacks */ void co_init(sblkp) struct b_coexpr *sblkp; { -#ifndef Coexpr - syserr("co_init() called, but co-expressions not implemented"); -#else /* Coexpr */ register word *newsp; register struct b_refresh *rblkp; register dptr dp, dsp; @@ -27,60 +20,16 @@ struct b_coexpr *sblkp; * Get pointer to refresh block. */ rblkp = (struct b_refresh *)BlkLoc(sblkp->freshblk); - -#if COMPILER - na = rblkp->nargs; /* number of arguments */ - nl = rblkp->nlocals; /* number of locals */ - nt = rblkp->ntemps; /* number of temporaries */ - - /* - * The C stack must be aligned on the correct boundary. For up-growing - * stacks, the C stack starts after the initial procedure frame of - * the co-expression block. For down-growing stacks, the C stack starts - * at the last word of the co-expression block. - */ -#ifdef UpStack - frame_size = sizeof(struct p_frame) + sizeof(struct descrip) * (nl + na + - nt - 1) + rblkp->wrk_size; - stack_strt = (word)((char *)&sblkp->pf + frame_size + StackAlign*WordSize); -#else /* UpStack */ - stack_strt = (word)((char *)sblkp + stksize - WordSize); -#endif /* UpStack */ - sblkp->cstate[0] = stack_strt & ~(WordSize * StackAlign - 1); - - sblkp->es_argp = &sblkp->pf.tend.d[nl + nt]; /* args follow temporaries */ - -#else /* COMPILER */ - na = (rblkp->pfmkr).pf_nargs + 1; /* number of arguments */ nl = (int)rblkp->numlocals; /* number of locals */ /* * The interpreter stack starts at word after co-expression stack block. - * C stack starts at end of stack region on machines with down-growing C - * stacks and somewhere in the middle of the region. - * - * The C stack is aligned on a doubleword boundary. For up-growing - * stacks, the C stack starts in the middle of the stack portion - * of the static block. For down-growing stacks, the C stack starts - * at the last word of the static block. + * There is no longer C state in this region; pthreads makes another stack. */ newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr)); - -#ifdef UpStack - sblkp->cstate[0] = - ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2) - &~((word)WordSize*StackAlign-1)); -#else /* UpStack */ - sblkp->cstate[0] = - ((word)((char *)sblkp + stksize - WordSize) - &~((word)WordSize*StackAlign-1)); -#endif /* UpStack */ - - sblkp->es_argp = (dptr)newsp; /* args are first thing on stack */ - -#endif /* COMPILER */ + sblkp->es_argp = (dptr)newsp; /* args are first thing on stack */ /* * Copy arguments onto new stack. @@ -93,16 +42,6 @@ struct b_coexpr *sblkp; /* * Set up state variables and initialize procedure frame. */ -#if COMPILER - sblkp->es_pfp = &sblkp->pf; - sblkp->es_tend = &sblkp->pf.tend; - sblkp->pf.old_pfp = NULL; - sblkp->pf.rslt = NULL; - sblkp->pf.succ_cont = NULL; - sblkp->pf.tend.previous = NULL; - sblkp->pf.tend.num = nl + na + nt; - sblkp->es_actstk = NULL; -#else /* COMPILER */ *((struct pf_marker *)dsp) = rblkp->pfmkr; sblkp->es_pfp = (struct pf_marker *)dsp; sblkp->es_tend = NULL; @@ -111,25 +50,14 @@ struct b_coexpr *sblkp; sblkp->es_gfp = 0; sblkp->es_efp = 0; sblkp->es_ilevel = 0; -#endif /* COMPILER */ sblkp->tvalloc = NULL; /* * Copy locals into the co-expression. */ -#if COMPILER - dsp = sblkp->pf.tend.d; -#endif /* COMPILER */ for (i = 1; i <= nl; i++) *dsp++ = *dp++; -#if COMPILER - /* - * Initialize temporary variables. - */ - for (i = 1; i <= nt; i++) - *dsp++ = nulldesc; -#else /* COMPILER */ /* * Push two null descriptors on the stack. */ @@ -137,9 +65,6 @@ struct b_coexpr *sblkp; *dsp++ = nulldesc; sblkp->es_sp = (word *)dsp - 1; -#endif /* COMPILER */ - -#endif /* Coexpr */ } /* @@ -152,60 +77,22 @@ struct descrip *rsltloc;/* location to put result */ int swtch_typ; /* A_Coact, A_Coret, A_Cofail, or A_MTEvent */ int first; { -#ifndef Coexpr - syserr("co_chng() called, but co-expressions not implemented"); -#else /* Coexpr */ register struct b_coexpr *ccp; static int coexp_act; /* used to pass signal across activations */ /* back to whomever activates, if they care */ ccp = (struct b_coexpr *)BlkLoc(k_current); -#if !COMPILER -#ifdef EventMon - switch(swtch_typ) { - /* - * A_MTEvent does not generate an event. - */ - case A_MTEvent: - break; - case A_Coact: - EVValX(ncp,E_Coact); - if (!is:null(curpstate->eventmask)) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - case A_Coret: - EVValX(ncp,E_Coret); - if (!is:null(curpstate->eventmask)) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - case A_Cofail: - EVValX(ncp,E_Cofail); - if (!is:null(curpstate->eventmask) && ncp->program == curpstate) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - } -#endif /* EventMon */ -#endif /* COMPILER */ - /* * Determine if we need to transmit a value. */ if (valloc != NULL) { -#if !COMPILER /* * Determine if we need to dereference the transmitted value. */ if (Var(*valloc)) retderef(valloc, (word *)glbl_argp, sp); -#endif /* COMPILER */ if (ncp->tvalloc != NULL) *ncp->tvalloc = *valloc; @@ -220,31 +107,14 @@ int first; ccp->es_argp = glbl_argp; ccp->es_tend = tend; -#if !COMPILER ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; -#endif /* COMPILER */ - -#if COMPILER - if (line_info) { - ccp->file_name = file_name; - ccp->line_num = line_num; - file_name = ncp->file_name; - line_num = ncp->line_num; - } -#endif /* COMPILER */ -#if COMPILER - if (debug_info) -#endif /* COMPILER */ - if (k_trace) -#ifdef EventMon - if (swtch_typ != A_MTEvent) -#endif /* EventMon */ - cotrace(ccp, ncp, swtch_typ, valloc); + if (k_trace) + cotrace(ccp, ncp, swtch_typ, valloc); /* * Establish state for new co-expression. @@ -252,45 +122,20 @@ int first; pfp = ncp->es_pfp; tend = ncp->es_tend; -#if !COMPILER efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; -#endif /* COMPILER */ - -#if !COMPILER -#ifdef MultiThread - /* - * Enter the program state of the co-expression being activated - */ - ENTERPSTATE(ncp->program); -#endif /* MultiThread */ -#endif /* COMPILER */ glbl_argp = ncp->es_argp; BlkLoc(k_current) = (union block *)ncp; -#if COMPILER - coexpr_fnc = ncp->fnc; -#endif /* COMPILER */ - -#ifdef EventMon - /* - * From here on out, A_MTEvent looks like a A_Coact. - */ - if (swtch_typ == A_MTEvent) - swtch_typ = A_Coact; -#endif /* EventMon */ - coexp_act = swtch_typ; coswitch(ccp->cstate, ncp->cstate,first); return coexp_act; -#endif /* Coexpr */ } -#ifdef Coexpr /* * new_context - determine what function to call to execute the new * co-expression; this completes the context switch. @@ -299,17 +144,5 @@ void new_context(fsig,cargp) int fsig; dptr cargp; { -#if COMPILER - (*coexpr_fnc)(); -#else /* COMPILER */ interp(fsig, cargp); -#endif /* COMPILER */ - } -#else /* Coexpr */ -/* dummy new_context if co-expressions aren't supported */ -void new_context(fsig,cargp) -int fsig; -dptr cargp; - { } -#endif /* Coexpr */ diff --git a/src/runtime/rcomp.r b/src/runtime/rcomp.r index 6cd0610..2ad3e35 100644 --- a/src/runtime/rcomp.r +++ b/src/runtime/rcomp.r @@ -35,8 +35,6 @@ dptr dp1, dp2; switch (Type(*dp1)) { -#ifdef LargeInts - case T_Integer: if (Type(*dp2) != T_Lrgint) { v1 = IntVal(*dp1); @@ -56,20 +54,6 @@ dptr dp1, dp2; return Equal; return ((lresult > 0) ? Greater : Less); -#else /* LargeInts */ - - case T_Integer: - v1 = IntVal(*dp1); - v2 = IntVal(*dp2); - if (v1 < v2) - return Less; - else if (v1 == v2) - return Equal; - else - return Greater; - -#endif /* LargeInts */ - case T_Coexpr: /* * Collate on co-expression id. @@ -171,14 +155,15 @@ dptr dp1, dp2; return ((lresult > 0) ? Greater : Less); case T_External: - /* - * Collate these values according to the relative positions of - * their blocks in the heap. - */ - lresult = ((long)BlkLoc(*dp1) - (long)BlkLoc(*dp2)); - if (lresult == 0) - return Equal; - return ((lresult > 0) ? Greater : Less); + /* + * Call associated collation function. + */ + { + struct descrip result = callextfunc(&extlcmp, dp1, dp2); + long ans = result.vword.integr; + if (ans == 0) return Equal; + return ans > 0 ? Greater : Less; + } default: syserr("anycmp: unknown datatype."); @@ -201,17 +186,12 @@ dptr dp; return 0; case T_Integer: return 1; - -#ifdef LargeInts case T_Lrgint: return 1; -#endif /* LargeInts */ - case T_Real: return 2; - - /* string: return 3 (see above) */ - + /* String (handled above): /* + /* return 3; */ case T_Cset: return 4; case T_File: @@ -285,12 +265,9 @@ dptr dp1, dp2; result = (IntVal(*dp1) == IntVal(*dp2)); break; -#ifdef LargeInts case T_Lrgint: result = (bigcmp(dp1, dp2) == 0); break; -#endif /* LargeInts */ - case T_Real: GetReal(dp1, rres1); diff --git a/src/runtime/rdebug.r b/src/runtime/rdebug.r index 26d1167..589ebeb 100644 --- a/src/runtime/rdebug.r +++ b/src/runtime/rdebug.r @@ -18,28 +18,6 @@ static void xtrace * tracebk - print a trace of procedure calls. */ -#if COMPILER - -void tracebk(lcl_pfp, argp) -struct p_frame *lcl_pfp; -dptr argp; - { - struct b_proc *cproc; - - struct debug *debug; - word nparam; - - if (lcl_pfp == NULL) - return; - debug = PFDebug(*lcl_pfp); - tracebk(lcl_pfp->old_pfp, lcl_pfp->old_argp); - cproc = debug->proc; - xtrace(cproc, (word)abs((int)cproc->nparam), argp, debug->old_line, - debug->old_fname); - } - -#else /* COMPILER */ - void tracebk(lcl_pfp, argp) struct pf_marker *lcl_pfp; dptr argp; @@ -87,8 +65,6 @@ dptr argp; pfp = (struct pf_marker *)(pfp->pf_efp); } } - -#endif /* COMPILER */ /* * xtrace - procedure *bp is being called with nargs arguments, the first @@ -105,16 +81,11 @@ char *pfile; if (bp == NULL) fprintf(stderr, "????"); else { - -#if COMPILER - putstr(stderr, &(bp->pname)); -#else /* COMPILER */ if (arg[0].dword == D_Proc) putstr(stderr, &(bp->pname)); else outimage(stderr, arg, 0); arg++; -#endif /* COMPILER */ putc('(', stderr); while (nargs--) { @@ -147,15 +118,9 @@ int get_name(dp1,dp0) word i, j, k; int t; -#if COMPILER - arg1 = glbl_argp; - loc1 = pfp->tend.d; - proc = PFDebug(*pfp)->proc; -#else /* COMPILER */ arg1 = &glbl_argp[1]; loc1 = pfp->pf_locals; proc = &BlkLoc(*glbl_argp)->proc; -#endif /* COMPILER */ type_case *dp1 of { tvsubs: { @@ -196,14 +161,6 @@ int get_name(dp1,dp0) StrLen(*dp0) = 6; StrLoc(*dp0) = "&trace"; } - -#ifdef FncTrace - else if (VarLoc(*dp1) == &kywd_ftrc) { - StrLen(*dp0) = 7; - StrLoc(*dp0) = "&ftrace"; - } -#endif /* FncTrace */ - else if (VarLoc(*dp1) == &kywd_dmp) { StrLen(*dp0) = 5; StrLoc(*dp0) = "&dump"; @@ -216,21 +173,6 @@ int get_name(dp1,dp0) syserr("name: unknown integer keyword variable"); kywdevent: -#ifdef MultiThread - if (VarLoc(*dp1) == &curpstate->eventsource) { - StrLen(*dp0) = 12; - StrLoc(*dp0) = "&eventsource"; - } - else if (VarLoc(*dp1) == &curpstate->eventval) { - StrLen(*dp0) = 11; - StrLoc(*dp0) = "&eventvalue"; - } - else if (VarLoc(*dp1) == &curpstate->eventcode) { - StrLen(*dp0) = 10; - StrLoc(*dp0) = "&eventcode"; - } - else -#endif /* MultiThread */ syserr("name: unknown event keyword variable"); kywdwin: { @@ -293,20 +235,11 @@ int get_name(dp1,dp0) i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1; if (i < 1) i += blkptr->lelem.nslots; -#ifdef ListFix - while (BlkType(blkptr->lelem.listprev) == T_Lelem) { -#else /* ListFix */ while (blkptr->lelem.listprev != NULL) { -#endif /* ListFix */ blkptr = blkptr->lelem.listprev; i += blkptr->lelem.nused; } -#ifdef ListFix - sprintf(sbuf,"list_%d[%ld]", - (long)blkptr->lelem.listprev->list.id, (long)i); -#else /* ListFix */ sprintf(sbuf,"L[%ld]", (long)i); -#endif /* ListFix */ i = strlen(sbuf); Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error); StrLen(*dp0) = i; @@ -314,16 +247,8 @@ int get_name(dp1,dp0) case T_Record: /* record */ i = varptr - blkptr->record.fields; proc = &blkptr->record.recdesc->proc; - -#ifdef TableFix - sprintf(sbuf,"record %s_%d.%s", StrLoc(proc->recname), - blkptr->record.id, - StrLoc(proc->lnames[i])); -#else sprintf(sbuf,"%s.%s", StrLoc(proc->recname), StrLoc(proc->lnames[i])); -#endif - i = strlen(sbuf); Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error); StrLen(*dp0) = i; @@ -334,104 +259,13 @@ int get_name(dp1,dp0) return Error; break; default: /* none of the above */ -#ifdef EventMon - *dp0 = emptystr; -#else /* EventMon */ syserr("name: invalid structure reference"); -#endif /* EventMon */ - } } } return Succeeded; } -#if COMPILER -#begdef PTraceSetup() - struct b_proc *proc; - - --k_trace; - showline(file_name, line_num); - showlevel(k_level); - proc = PFDebug(*pfp)->proc; /* get address of procedure block */ - putstr(stderr, &proc->pname); -#enddef - -/* - * ctrace - a procedure is being called; produce a trace message. - */ -void ctrace() - { - dptr arg; - int n; - - PTraceSetup(); - - putc('(', stderr); - arg = glbl_argp; - n = abs((int)proc->nparam); - while (n--) { - outimage(stderr, arg++, 0); - if (n) - putc(',', stderr); - } - putc(')', stderr); - putc('\n', stderr); - fflush(stderr); - } - -/* - * rtrace - a procedure is returning; produce a trace message. - */ - -void rtrace() - { - PTraceSetup(); - - fprintf(stderr, " returned "); - outimage(stderr, pfp->rslt, 0); - putc('\n', stderr); - fflush(stderr); - } - -/* - * failtrace - procedure named s is failing; produce a trace message. - */ - -void failtrace() - { - PTraceSetup(); - - fprintf(stderr, " failed\n"); - fflush(stderr); - } - -/* - * strace - a procedure is suspending; produce a trace message. - */ - -void strace() - { - PTraceSetup(); - - fprintf(stderr, " suspended "); - outimage(stderr, pfp->rslt, 0); - putc('\n', stderr); - fflush(stderr); - } - -/* - * atrace - a procedure is being resumed; produce a trace message. - */ -void atrace() - { - PTraceSetup(); - - fprintf(stderr, " resumed\n"); - fflush(stderr); - } -#endif /* COMPILER */ - /* * keyref(bp,dp) -- print name of subscripted table */ @@ -451,16 +285,7 @@ static int keyref(bp, dp) */ s2 = StrLoc(*dp); len = StrLen(*dp); -#ifdef TableFix - if (BlkType(bp) == T_Tvtbl) - bp = bp->tvtbl.clink; - else - while(BlkType(bp) == T_Telem) - bp = bp->telem.clink; - sprintf(sbuf, "table_%d[", bp->table.id); -#else /* TableFix */ strcpy(sbuf, "T["); -#endif /* TableFix */ { char * dest = sbuf + strlen(sbuf); strncpy(dest, s2, len); dest[len] = '\0'; @@ -473,7 +298,6 @@ static int keyref(bp, dp) return Succeeded; } -#ifdef Coexpr /* * cotrace -- a co-expression context switch; produce a trace message. */ @@ -484,26 +308,16 @@ int swtch_typ; dptr valloc; { struct b_proc *proc; - -#if !COMPILER inst t_ipc; -#endif /* !COMPILER */ --k_trace; -#if COMPILER - showline(ccp->file_name, ccp->line_num); - proc = PFDebug(*ccp->es_pfp)->proc; /* get address of procedure block */ -#else /* COMPILER */ - /* * Compute the ipc of the instruction causing the context switch. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); proc = (struct b_proc *)BlkLoc(*glbl_argp); -#endif /* COMPILER */ - showlevel(k_level); putstr(stderr, &proc->pname); fprintf(stderr,"; co-expression_%ld ", (long)ccp->id); @@ -525,7 +339,6 @@ dptr valloc; fprintf(stderr,"co-expression_%ld\n", (long)ncp->id); fflush(stderr); } -#endif /* Coexpr */ /* * showline - print file and line number information. @@ -559,11 +372,8 @@ register int n; } } -#if !COMPILER - #include "../h/opdefs.h" - extern struct descrip value_tmp; /* argument of Op_Apply */ extern struct b_proc *opblks[]; @@ -812,7 +622,6 @@ dptr dp; fflush(stderr); } -#ifdef Coexpr /* * coacttrace -- co-expression is being activated; produce a trace message. */ @@ -883,8 +692,6 @@ struct b_coexpr *ncp; (long)ccp->id, (long)ncp->id); fflush(stderr); } -#endif /* Coexpr */ -#endif /* !COMPILER */ /* * Service routine to display variables in given number of @@ -892,11 +699,7 @@ struct b_coexpr *ncp; */ int xdisp(fp,dp,count,f) -#if COMPILER - struct p_frame *fp; -#else /* COMPILER */ struct pf_marker *fp; -#endif /* COMPILER */ register dptr dp; int count; FILE *f; @@ -909,13 +712,7 @@ int xdisp(fp,dp,count,f) while (count--) { /* go back through 'count' frames */ if (fp == NULL) break; /* needed because &level is wrong in co-expressions */ - -#if COMPILER - bp = PFDebug(*fp)->proc; /* get address of procedure block */ -#else /* COMPILER */ bp = (struct b_proc *)BlkLoc(*dp++); /* get addr of procedure block */ - /* #%#% was: no post-increment there, but *pre*increment dp below */ -#endif /* COMPILER */ /* * Print procedure name. @@ -939,11 +736,7 @@ int xdisp(fp,dp,count,f) /* * Print locals. */ -#if COMPILER - dp = fp->tend.d; -#else /* COMPILER */ dp = &fp->pf_locals[0]; -#endif /* COMPILER */ for (n = bp->ndynam; n > 0; n--) { fprintf(f, " "); putstr(f, np); @@ -965,26 +758,14 @@ int xdisp(fp,dp,count,f) putc('\n', f); np++; } - -#if COMPILER - dp = fp->old_argp; - fp = fp->old_pfp; -#else /* COMPILER */ dp = fp->pf_argp; fp = fp->pf_pfp; -#endif /* COMPILER */ } /* * Print globals. Sort names in lexical order using temporary index array. */ - -#if COMPILER - nglobals = n_globals; -#else /* COMPILER */ nglobals = eglobals - globals; -#endif /* COMPILER */ - indices = (word *)malloc(nglobals * sizeof(word)); if (indices == NULL) return Failed; diff --git a/src/runtime/rexternal.r b/src/runtime/rexternal.r new file mode 100644 index 0000000..c3a33c6 --- /dev/null +++ b/src/runtime/rexternal.r @@ -0,0 +1,136 @@ +/* + * File: rexternal.r + * Functions dealing with external values and their custom functions. + * + * Functions in this file that declare (argc, argv) signatures + * follow the ipl/cfuncs/icall.h calling conventions and call + * dynamically loaded C functions if available for this external type. + */ + +/* + * callextfunc(func, d1, d2) -- call func(argc, argv) via icall.h conventions. + * + * func() is called with argv=1 if d2 is null or argv=2 if not. + */ +struct descrip callextfunc(int (*func)(int, dptr), dptr dp1, dptr dp2) { + struct descrip stack[3]; + int nargs = 1; + + stack[0] = nulldesc; + stack[1] = *dp1; + if (dp2 != NULL) { + stack[2] = *dp2; + nargs = 2; + } + if (func(nargs, stack) != 0) + syserr("external value helper function did not succeed"); + return stack[0]; + } + +/* + * extlname(argc, argv) - return the name of the type of external value argv[1]. + */ +int extlname(int argc, dptr argv) + { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + + if (funcs->extlname != NULL) { + funcs->extlname(1, argv); /* call custom name function */ + if (! is:string(argv[0])) + syserr("extlname: not a string"); + } + else { + argv[0].dword = 8; /* strlen("external") */ + argv[0].vword.sptr = "external"; + } + return 0; + } + +/* + * extlimage(argc, argv) - return the image of external value argv[1]. + * + * Always sets argv[0] to a valid string, but returns Error + * if storage is not available for formatting the details. + */ +int extlimage(int argc, dptr argv) + { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + word len; + int nwords; + + if (funcs->extlimage != NULL) { + funcs->extlimage(1, argv); /* call custom image function */ + if (! is:string(argv[0])) + syserr("extlimage: not a string"); + return 0; + } + + extlname(1, &argv[0]); /* get type name, result in argv[0] */ + len = StrLen(argv[0]); + Protect(reserve(Strings, len + 30), return Error); + Protect(StrLoc(argv[0]) = alcstr(StrLoc(argv[0]), len), return Error); + /* + * to type name append "_<id>(nwords)" + */ + nwords = ((char*)block + block->blksize - (char*)block->data) / sizeof(word); + len += sprintf(StrLoc(argv[0]) + len, "_%ld(%d)", (long)block->id, nwords); + StrLen(argv[0]) = len; + return 0; + } + +/* + * extlcmp(argc, argv) - compare two external values argv[1] and argv[2]. + */ + +int extlcmp(int argc, dptr argv) { + struct b_external *block1 = (struct b_external *)BlkLoc(argv[1]); + struct b_external *block2 = (struct b_external *)BlkLoc(argv[2]); + struct b_extlfuns *funcs = block1->funcs; + + /* + * If the two values share the same function list, then by definition + * they are the same type and are compared using a custom function if + * one is provided in the list. + */ + if (block1->funcs == block2->funcs && funcs->extlcmp != NULL) { + funcs->extlcmp(1, argv); /* call custom comparison function */ + if (! is:integer(argv[0])) + syserr("extlcmp: not an integer"); + } + else { + /* + * Otherwise, sort by name and then by serial number. + */ + struct descrip name1 = callextfunc(&extlname, &argv[1], NULL); + struct descrip name2 = callextfunc(&extlname, &argv[2], NULL); + long result = lexcmp(&name1, &name2); + if (result == Equal) + result = block1->id - block2->id; + argv[0].dword = D_Integer; + argv[0].vword.integr = result; + } + return 0; + } + +/* + * extlcopy(argc, argv) - return a copy of external value argv[1]. + * + * By default this is the original descriptor. + */ + +int extlcopy(int argc, dptr argv) { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + + if (funcs->extlcopy != NULL) { + funcs->extlcopy(1, argv); /* call custom copy function */ + if (Qual(argv[0]) || Type(argv[0]) != T_External) + syserr("extlcopy: not an external"); + } + else { + argv[0] = argv[1]; /* the identical external value */ + } + return 0; + } diff --git a/src/runtime/rlrgint.r b/src/runtime/rlrgint.r index f624cc7..ec1aaa4 100644 --- a/src/runtime/rlrgint.r +++ b/src/runtime/rlrgint.r @@ -3,8 +3,6 @@ * Large integer arithmetic */ -#ifdef LargeInts - extern int over_flow; /* @@ -2298,5 +2296,3 @@ word n; return 0; return u[n - 1] > (DIGIT)k ? 1 : -1; } - -#endif /* LargeInts */ diff --git a/src/runtime/rmemmgt.r b/src/runtime/rmemmgt.r index 4a9daa2..8cc6956 100644 --- a/src/runtime/rmemmgt.r +++ b/src/runtime/rmemmgt.r @@ -20,20 +20,13 @@ static void adjust (char *source, char *dest); static void compact (char *source); static void mvc (uword n, char *src, char *dest); -#ifdef MultiThread -static void markprogram (struct progstate *pstate); -#endif /*MultiThread*/ - /* * Variables */ - -#ifndef MultiThread word coll_stat = 0; /* collections in static region */ word coll_str = 0; /* collections in string region */ word coll_blk = 0; /* collections in block region */ word coll_tot = 0; /* total collections */ -#endif /* MultiThread */ word alcnum = 0; /* co-expressions allocated since g.c. */ dptr *quallist; /* string qualifier list */ @@ -89,13 +82,7 @@ int firstd[] = { 0, /* T_Real (3), real number */ 0, /* T_Cset (4), cset */ 3*WordSize, /* T_File (5), file block */ - -#ifdef MultiThread - 8*WordSize, /* T_Proc (6), procedure block */ -#else /* MultiThread */ 7*WordSize, /* T_Proc (6), procedure block */ -#endif /* MultiThread */ - 4*WordSize, /* T_Record (7), record block */ 0, /* T_List (8), list header block */ 7*WordSize, /* T_Lelem (9), list element block */ @@ -106,13 +93,7 @@ int firstd[] = { 3*WordSize, /* T_Tvtbl (14), table element trapped variable */ 0, /* T_Slots (15), set/table hash block */ 3*WordSize, /* T_Tvsubs (16), substring trapped variable */ - -#if COMPILER - 2*WordSize, /* T_Refresh (17), refresh block */ -#else /* COMPILER */ (4+Wsizeof(struct pf_marker))*WordSize, /* T_Refresh (17), refresh block */ -#endif /* COMPILER */ - -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ -1, /* T_Kywdint (20), integer keyword variable */ @@ -252,35 +233,18 @@ uword segsize[] = { * initalloc - initialization routine to allocate memory regions */ -#if COMPILER -void initalloc() - { - -#else /* COMPILER */ -#ifdef MultiThread -void initalloc(codesize,p) -struct progstate *p; -#else /* MultiThread */ void initalloc(codesize) -#endif /* MultiThread */ word codesize; { -#ifdef MultiThread - struct region *ps, *pb; -#endif if ((uword)codesize > (unsigned)MaxBlock) error(NULL, "icode file too large"); /* * Allocate icode region */ -#ifdef MultiThread - if (codesize) -#endif /* MultiThread */ if ((code = (char *)AllocReg(codesize)) == NULL) error(NULL, "insufficient memory, corrupted icode file, or wrong platform"); -#endif /* COMPILER */ /* * Set up allocated memory. The regions are: @@ -290,25 +254,6 @@ word codesize; * Qualifier list */ -#ifdef MultiThread - ps = p->stringregion; - ps->free = ps->base = (char *)AllocReg(ps->size); - if (ps->free == NULL) - error(NULL, "insufficient memory for string region"); - ps->end = ps->base + ps->size; - - pb = p->blockregion; - pb->free = pb->base = (char *)AllocReg(pb->size); - if (pb->free == NULL) - error(NULL, "insufficient memory for block region"); - pb->end = pb->base + pb->size; - - if (p == &rootpstate) { - if ((quallist = (dptr *)malloc(qualsize)) == NULL) - error(NULL, "insufficient memory for qualifier list"); - equallist = (dptr *)((char *)quallist + qualsize); - } -#else /* MultiThread */ { uword t1, t2; t1 = ssize; @@ -331,7 +276,6 @@ word codesize; if ((quallist = (dptr *)malloc(qualsize)) == NULL) error(NULL, "insufficient memory for qualifier list"); equallist = (dptr *)((char *)quallist + qualsize); -#endif /* MultiThread */ } /* @@ -343,11 +287,6 @@ int region; { struct b_coexpr *cp; -#ifdef EventMon - if (!noMTevents) - EVVal((word)region,E_Collect); -#endif /* EventMon */ - switch (region) { case Static: coll_stat++; @@ -366,11 +305,8 @@ int region; /* * Garbage collection cannot be done until initialization is complete. */ - -#if !COMPILER if (sp == NULL) return 0; -#endif /* !COMPILER */ /* * Sync the values (used by sweep) in the coexpr block for ¤t @@ -378,13 +314,10 @@ int region; */ cp = (struct b_coexpr *)BlkLoc(k_current); cp->es_tend = tend; - -#if !COMPILER cp->es_pfp = pfp; cp->es_gfp = gfp; cp->es_efp = efp; cp->es_sp = sp; -#endif /* !COMPILER */ /* * Reset qualifier list. @@ -395,18 +328,13 @@ int region; /* * Mark the stacks for &main and the current co-expression. */ -#ifdef MultiThread - markprogram(&rootpstate); -#endif /* MultiThread */ markblock(&k_main); markblock(&k_current); /* * Mark &subject and the cached s2 and s3 strings for map. */ -#ifndef MultiThread postqual(&k_subject); postqual(&kywd_prog); -#endif /* MultiThread */ if (Qual(maps2)) /* caution: the cached arguments of */ postqual(&maps2); /* map may not be strings. */ else if (Pointer(maps2)) @@ -436,7 +364,6 @@ int region; * Mark the globals and the statics. */ -#ifndef MultiThread { register struct descrip *dp; for (dp = globals; dp < eglobals; dp++) if (Qual(*dp)) @@ -457,7 +384,6 @@ int region; if (is:file(lastEventWin)) markblock(&(lastEventWin)); #endif /* Graphics */ -#endif /* MultiThread */ reclaim(); @@ -483,75 +409,10 @@ int region; } } -#ifdef EventMon - if (!noMTevents) { - mmrefresh(); - EVValD(&nulldesc, E_EndCollect); - } -#endif /* EventMon */ - return 1; } /* - * markprogram - traverse pointers out of a program state structure - */ - -#ifdef MultiThread -#define PostDescrip(d) \ - if (Qual(d)) \ - postqual(&(d)); \ - else if (Pointer(d))\ - markblock(&(d)); - -static void markprogram(pstate) -struct progstate *pstate; - { - struct descrip *dp; - - PostDescrip(pstate->parentdesc); - PostDescrip(pstate->eventmask); - PostDescrip(pstate->opcodemask); - PostDescrip(pstate->eventcode); - PostDescrip(pstate->eventval); - PostDescrip(pstate->eventsource); - - /* Kywd_err, &error, always an integer */ - /* Kywd_pos, &pos, always an integer */ - postqual(&(pstate->ksub)); - postqual(&(pstate->Kywd_prog)); - /* Kywd_ran, &random, always an integer */ - /* Kywd_trc, &trace, always an integer */ - - /* - * Mark the globals and the statics. - */ - for (dp = pstate->Globals; dp < pstate->Eglobals; dp++) - if (Qual(*dp)) - postqual(dp); - else if (Pointer(*dp)) - markblock(dp); - - for (dp = pstate->Statics; dp < pstate->Estatics; dp++) - if (Qual(*dp)) - postqual(dp); - else if (Pointer(*dp)) - markblock(dp); - - /* - * no marking for &x, &y, &row, &col, &interval, all integers - */ -#ifdef Graphics - PostDescrip(pstate->LastEventWin); /* last Event() win */ - PostDescrip(pstate->Kywd_xwin[XKey_Window]); /* &window */ -#endif /* Graphics */ - - PostDescrip(pstate->K_errorvalue); - PostDescrip(pstate->T_errorvalue); - } -#endif /* MultiThread */ - -/* * postqual - mark a string qualifier. Strings outside the string space * are ignored. */ @@ -693,17 +554,6 @@ dptr dp; BlkType(block) = (uword)dp; sweep((struct b_coexpr *)block); -#ifdef MultiThread - if (((struct b_coexpr *)block)+1 == - (struct b_coexpr *)((struct b_coexpr *)block)->program){ - /* - * This coexpr is an &main; traverse its roots - */ - markprogram(((struct b_coexpr *)block)->program); - } -#endif /* MultiThread */ - -#ifdef Coexpr /* * Mark the activators of this co-expression. The activators are * stored as a list of addresses, but markblock requires the address @@ -723,7 +573,6 @@ dptr dp; } if(BlkLoc(cp->freshblk) != NULL) markblock(&((struct b_coexpr *)block)->freshblk); -#endif /* Coexpr */ } else { @@ -950,12 +799,9 @@ struct b_coexpr *ce; } } } -#if !COMPILER sweep_stk(ce); -#endif /* !COMPILER */ } -#if !COMPILER /* * sweep_stk - sweep the stack, marking all descriptors there. Method * is to start at a known point, specifically, the frame that the @@ -992,19 +838,6 @@ struct b_coexpr *ce; s_sp = ce->es_sp; nargs = 0; /* Nargs counter is 0 initially. */ -#ifdef MultiThread - if (fp == 0) { - if (is:list(* (dptr) (s_sp - 1))) { - /* - * this is the argument list of an un-started task - */ - if (Pointer(*((dptr)(&s_sp[-1])))) { - markblock((dptr)&s_sp[-1]); - } - } - } -#endif /* MultiThread */ - while ((fp != 0 || nargs)) { /* Keep going until current fp is 0 and no arguments are left. */ if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) { @@ -1071,7 +904,6 @@ struct b_coexpr *ce; } } } -#endif /* !COMPILER */ /* * reclaim - reclaim space in the allocated memory regions. The marking @@ -1118,11 +950,7 @@ static void cofree() * Reset the type for &main. */ -#ifdef MultiThread - rootpstate.Mainhead->title = T_Coexpr; -#else /* MultiThread */ BlkLoc(k_main)->coexpr.title = T_Coexpr; -#endif /* MultiThread */ /* * The co-expression blocks are linked together through their @@ -1145,9 +973,7 @@ static void cofree() abp = abp->astk_nxt; free((pointer)xabp); } - #ifdef CoClean - coclean(xep->cstate); - #endif /* CoClean */ + coclean(xep->cstate); free((pointer)xep); } else { @@ -1392,68 +1218,3 @@ register char *src, *dest; * Note that src == dest implies no action */ } - -#ifdef DeBugIconx -/* - * descr - dump a descriptor. Used only for debugging. - */ - -void descr(dp) -dptr dp; - { - int i; - - fprintf(stderr,"%08lx: ",(long)dp); - if (Qual(*dp)) - fprintf(stderr,"%15s","qualifier"); - - else if (Var(*dp)) - fprintf(stderr,"%15s","variable"); - else { - i = Type(*dp); - switch (i) { - case T_Null: - fprintf(stderr,"%15s","null"); - break; - case T_Integer: - fprintf(stderr,"%15s","integer"); - break; - default: - fprintf(stderr,"%15s",blkname[i]); - } - } - fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp)); - } - -/* - * blkdump - dump the allocated block region. Used only for debugging. - * NOTE: Not adapted for multiple regions. - */ - -void blkdump() - { - register char *blk; - register word type, size, fdesc; - register dptr ndesc; - - fprintf(stderr, - "\nDump of allocated block region. base:%08lx free:%08lx max:%08lx\n", - (long)blkbase,(long)blkfree,(long)blkend); - fprintf(stderr," loc type size contents\n"); - - for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) { - type = BlkType(blk); - size = BlkSize(blk); - fprintf(stderr," %08lx %15s %4ld\n",(long)blk,blkname[type], - (long)size); - if ((fdesc = firstd[type]) > 0) - for (ndesc = (dptr)(blk + fdesc); - ndesc < (dptr)(blk + size); ndesc++) { - fprintf(stderr," "); - descr(ndesc); - } - fprintf(stderr,"\n"); - } - fprintf(stderr,"end of block region.\n"); - } -#endif /* DeBugIconx */ diff --git a/src/runtime/rmisc.r b/src/runtime/rmisc.r index a302da2..18097c5 100644 --- a/src/runtime/rmisc.r +++ b/src/runtime/rmisc.r @@ -50,17 +50,7 @@ int getvar(s,vp) register dptr np; register int i; struct b_proc *bp; -#if COMPILER - struct descrip sdp; - - if (!debug_info) - fatalerr(402,NULL); - - StrLoc(sdp) = s; - StrLen(sdp) = strlen(s); -#else /* COMPILER */ struct pf_marker *fp = pfp; -#endif /* COMPILER */ /* * Is it a keyword that's a variable? @@ -97,15 +87,6 @@ int getvar(s,vp) VarLoc(*vp) = &kywd_trc; return Succeeded; } - -#ifdef FncTrace - else if (strcmp(s,"&ftrace") == 0) { - vp->dword = D_Kywdint; - VarLoc(*vp) = &kywd_ftrc; - return Succeeded; - } -#endif /* FncTrace */ - else if (strcmp(s,"&dump") == 0) { vp->dword = D_Kywdint; VarLoc(*vp) = &kywd_dmp; @@ -119,24 +100,6 @@ int getvar(s,vp) } #endif /* Graphics */ -#ifdef MultiThread - else if (strcmp(s,"&eventvalue") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventval); - return Succeeded; - } - else if (strcmp(s,"&eventsource") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventsource); - return Succeeded; - } - else if (strcmp(s,"&eventcode") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventcode); - return Succeeded; - } -#endif /* MultiThread */ - else return Failed; } @@ -149,53 +112,31 @@ int getvar(s,vp) * If no such variable exits, it fails. */ -#if !COMPILER /* * If no procedure has been called (as can happen with icon_call(), * dont' try to find local identifier. */ if (pfp == NULL) goto glbvars; -#endif /* !COMPILER */ dp = glbl_argp; -#if COMPILER - bp = PFDebug(*pfp)->proc; /* get address of procedure block */ -#else /* COMPILER */ bp = (struct b_proc *)BlkLoc(*dp); /* get address of procedure block */ -#endif /* COMPILER */ np = bp->lnames; /* Check the formal parameter names. */ for (i = abs((int)bp->nparam); i > 0; i--) { -#if COMPILER - if (eq(&sdp, np) == 1) { -#else /* COMPILER */ dp++; if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return ParamName; } np++; -#if COMPILER - dp++; -#endif /* COMPILER */ } - -#if COMPILER - dp = &pfp->tend.d[0]; -#else /* COMPILER */ dp = &fp->pf_locals[0]; -#endif /* COMPILER */ for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */ -#if COMPILER - if (eq(&sdp, np)) { -#else /* COMPILER */ if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return LocalName; @@ -206,11 +147,7 @@ int getvar(s,vp) dp = &statics[bp->fstatic]; /* Check the local static names. */ for (i = (int)bp->nstatic; i > 0; i--) { -#if COMPILER - if (eq(&sdp, np)) { -#else /* COMPILER */ if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return StaticName; @@ -219,15 +156,6 @@ int getvar(s,vp) dp++; } -#if COMPILER - for (i = 0; i < n_globals; ++i) { - if (eq(&sdp, &gnames[i])) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&globals[i]; - return GlobalName; - } - } -#else /* COMPILER */ glbvars: dp = globals; /* Check the global variable names. */ np = gnames; @@ -240,7 +168,6 @@ glbvars: np++; dp++; } -#endif /* COMPILER */ return Failed; } @@ -288,7 +215,6 @@ dptr dp; i = (13255 * (uword)IntVal(*dp)) >> 10; break; -#ifdef LargeInts /* * The hash value of a bignum is based on its length and its * most and least significant digits. @@ -301,7 +227,6 @@ dptr dp; (b->digits[b->msd] << 8) ^ b->digits[b->lsd]; } break; -#endif /* LargeInts */ /* * The hash value of a real number is itself times a constant, @@ -412,15 +337,10 @@ int noimage; fprintf(f, "&null"); integer: - -#ifdef LargeInts if (Type(*dp) == T_Lrgint) bigprint(f, dp); else fprintf(f, "%ld", (long)IntVal(*dp)); -#else /* LargeInts */ - fprintf(f, "%ld", (long)IntVal(*dp)); -#endif /* LargeInts */ real: { char s[30]; @@ -436,7 +356,7 @@ int noimage; * Check for a predefined cset; use keyword name if found. */ if ((csn = csname(dp)) != NULL) { - fprintf(f, csn); + fprintf(f, "%s", csn); return; } /* @@ -628,12 +548,6 @@ int noimage; fprintf(f, "&random = "); else if (VarLoc(*dp) == &kywd_trc) fprintf(f, "&trace = "); - -#ifdef FncTrace - else if (VarLoc(*dp) == &kywd_ftrc) - fprintf(f, "&ftrace = "); -#endif /* FncTrace */ - else if (VarLoc(*dp) == &kywd_dmp) fprintf(f, "&dump = "); else if (VarLoc(*dp) == &kywd_err) @@ -642,14 +556,6 @@ int noimage; } kywdevent: { -#ifdef MultiThread - if (VarLoc(*dp) == &curpstate->eventsource) - fprintf(f, "&eventsource = "); - else if (VarLoc(*dp) == &curpstate->eventcode) - fprintf(f, "&eventcode = "); - else if (VarLoc(*dp) == &curpstate->eventval) - fprintf(f, "&eventval = "); -#endif /* MultiThread */ outimage(f, VarLoc(*dp), noimage); } @@ -682,8 +588,13 @@ int noimage; outimage(f, dp, noimage); putc(')', f); } - else if (Type(*dp) == T_External) - fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize); + else if (Type(*dp) == T_External) { + q = callextfunc(&extlimage, dp, NULL); /* get image as a string */ + i = StrLen(q); + s = StrLoc(q); + while (i-- > 0) + putc(*s++, f); + } else if (Type(*dp) <= MaxType) fprintf(f, "%s", blkname[Type(*dp)]); else @@ -848,7 +759,6 @@ int (*compar)(); return 0; } -#if !COMPILER /* * qtos - convert a qualified string named by *dp to a C-style string. * Put the C-style string in sbuf if it will fit, otherwise put it @@ -883,9 +793,7 @@ char *sbuf; } return Succeeded; } -#endif /* !COMPILER */ -#ifdef Coexpr /* * pushact - push actvtr on the activator stack of ce */ @@ -895,10 +803,6 @@ struct b_coexpr *ce, *actvtr; struct astkblk *abp = ce->es_actstk, *nabp; struct actrec *arp; -#ifdef MultiThread - abp->arec[0].activator = actvtr; -#else /* MultiThread */ - /* * If the last activator is the same as this one, just increment * its count. @@ -924,10 +828,8 @@ struct b_coexpr *ce, *actvtr; arp->acount = 1; arp->activator = actvtr; ce->es_actstk = abp; -#endif /* MultiThread */ return Succeeded; } -#endif /* Coexpr */ /* * popact - pop the most recent activator from the activator stack of ce @@ -936,17 +838,10 @@ struct b_coexpr *ce, *actvtr; struct b_coexpr *popact(ce) struct b_coexpr *ce; { - -#ifdef Coexpr - struct astkblk *abp = ce->es_actstk, *oabp; struct actrec *arp; struct b_coexpr *actvtr; -#ifdef MultiThread - return abp->arec[0].activator; -#else /* MultiThread */ - /* * If the current stack block is empty, pop it. */ @@ -971,15 +866,8 @@ struct b_coexpr *ce; ce->es_actstk = abp; return actvtr; -#endif /* MultiThread */ - -#else /* Coexpr */ - syserr("popact() called, but co-expressions not implemented"); -#endif /* Coexpr */ - } -#ifdef Coexpr /* * topact - return the most recent activator of ce. */ @@ -988,48 +876,14 @@ struct b_coexpr *ce; { struct astkblk *abp = ce->es_actstk; -#ifdef MultiThread - return abp->arec[0].activator; -#else /* MultiThread */ if (abp->nactivators == 0) abp = abp->astk_nxt; return abp->arec[abp->nactivators-1].activator; -#endif /* MultiThread */ } -#ifdef DeBugIconx -/* - * dumpact - dump an activator stack - */ -void dumpact(ce) -struct b_coexpr *ce; -{ - struct astkblk *abp = ce->es_actstk; - struct actrec *arp; - int i; - - if (abp) - fprintf(stderr, "Ce %ld ", (long)ce->id); - while (abp) { - fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n", - abp, abp->nactivators); - for (i = abp->nactivators; i >= 1; i--) { - arp = &abp->arec[i-1]; - /*for (j = 1; j <= arp->acount; j++)*/ - fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id), - arp->acount); - } - abp = abp->astk_nxt; - } -} -#endif /* DeBugIconx */ -#endif /* Coexpr */ - -#if !COMPILER /* * findline - find the source line number associated with the ipc */ -#ifdef SrcColumnInfo int findline(ipc) word *ipc; { @@ -1042,19 +896,12 @@ word *ipc; } int findloc(ipc) -#else /* SrcColumnInfo */ -int findline(ipc) -#endif /* SrcColumnInfo */ word *ipc; { uword ipc_offset; uword size; struct ipc_line *base; - -#ifndef MultiThread extern struct ipc_line *ilines, *elines; -#endif /* MultiThread */ - static int two = 2; /* some compilers generate bad code for division by a constant that is a power of two ... */ @@ -1084,11 +931,7 @@ int line; { uword size; struct ipc_line *base; - -#ifndef MultiThread extern struct ipc_line *ilines, *elines; -#endif /* MultiThread */ - static int two = 2; /* some compilers generate bad code for division by a constant that is a power of two ... */ @@ -1113,10 +956,7 @@ word *ipc; { uword ipc_offset; struct ipc_fname *p; - -#ifndef MultiThread extern struct ipc_fname *filenms, *efilenms; -#endif /* MultiThread */ if (!InRange(code,ipc,ecode)) return "?"; @@ -1130,7 +970,6 @@ word *ipc; /*NOTREACHED*/ return 0; /* avoid gcc warning */ } -#endif /* !COMPILER */ /* * doimage(c,q) - allocate character c in string space, with escape @@ -1249,7 +1088,6 @@ dptr dp1, dp2; } integer: { -#ifdef LargeInts if (Type(source) == T_Lrgint) { word slen; word dlen; @@ -1271,9 +1109,6 @@ dptr dp1, dp2; } else cnv: string(source, *dp2); -#else /* LargeInts */ - cnv:string(source, *dp2); -#endif /* LargeInts */ } real: { @@ -1472,16 +1307,9 @@ dptr dp1, dp2; } default: - if (Type(*dp1) == T_External) { - /* - * For now, just produce "external(n)". - */ - sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize); - len = strlen(sbuf); - Protect(t = alcstr(sbuf, len), return Error); - StrLoc(*dp2) = t; - StrLen(*dp2) = len; - } + if (Type(*dp1) == T_External) { + *dp2 = callextfunc(&extlimage, dp1, NULL); + } else { ReturnErrVal(123, source, Error); } @@ -1685,100 +1513,6 @@ word a; return -a; } -#if COMPILER -/* - * sig_rsm - standard success continuation that just signals resumption. - */ - -int sig_rsm() - { - return A_Resume; - } - -/* - * cmd_line - convert command line arguments into a list of strings. - */ -void cmd_line(argc, argv, rslt) -int argc; -char **argv; -dptr rslt; - { - tended struct b_list *hp; - register word i; - register struct b_lelem *bp; /* need not be tended */ - - /* - * Skip the program name. - */ - --argc; - ++argv; - - /* - * Allocate the list and a list block. - */ - Protect(hp = alclist(argc), fatalerr(0,NULL)); - Protect(bp = alclstb(argc, (word)0, argc), fatalerr(0,NULL)); - - /* - * Make the list block just allocated into the first and last blocks - * for the list. - */ - hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ - - /* - * Copy the arguments into the list - */ - for (i = 0; i < argc; ++i) { - StrLen(bp->lslots[i]) = strlen(argv[i]); - StrLoc(bp->lslots[i]) = argv[i]; - } - - rslt->dword = D_List; - rslt->vword.bptr = (union block *) hp; - } - -/* - * varargs - construct list for use in procedures with variable length - * argument list. - */ -void varargs(argp, nargs, rslt) -dptr argp; -int nargs; -dptr rslt; - { - tended struct b_list *hp; - register word i; - register struct b_lelem *bp; /* need not be tended */ - - /* - * Allocate the list and a list block. - */ - Protect(hp = alclist(nargs), fatalerr(0,NULL)); - Protect(bp = alclstb(nargs, (word)0, nargs), fatalerr(0,NULL)); - - /* - * Make the list block just allocated into the first and last blocks - * for the list. - */ - hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ - - /* - * Copy the arguments into the list - */ - for (i = 0; i < nargs; i++) - deref(&argp[i], &bp->lslots[i]); - - rslt->dword = D_List; - rslt->vword.bptr = (union block *) hp; - } -#endif /* COMPILER */ - /* * retderef - Dereference local variables and substrings of local * string-valued variables. This is used for return, suspend, and diff --git a/src/runtime/rmswin.ri b/src/runtime/rmswin.ri index 3471fd3..317e95f 100644 --- a/src/runtime/rmswin.ri +++ b/src/runtime/rmswin.ri @@ -232,7 +232,7 @@ FILE *wopen(char *name, struct b_list *lp, dptr attr, int n, int *err_idx) if (! winInitialized++) { BORDWIDTH = FRAMEWIDTH * 2; - BORDHEIGHT = TITLEHEIGHT + FRAMEHEIGHT * 2 - 1; + BORDHEIGHT = TITLEHEIGHT + FRAMEHEIGHT * 2; GetCPInfo(CP_ACP, &cpinfo); MAXBYTESPERCHAR = cpinfo.MaxCharSize; } @@ -299,10 +299,10 @@ FILE *wopen(char *name, struct b_list *lp, dptr attr, int n, int *err_idx) palette = CreatePalette(logpal); if ((scp = malloc(2 * sizeof (struct wcolor))) == NULL) return NULL; scp[0].c = RGB(0,0,0); - scp[0].type = SHARED; + scp[0].type = CSHARED; strcpy(scp[0].name, "black"); scp[1].c = RGB(255,255,255); - scp[1].type = SHARED; + scp[1].type = CSHARED; strcpy(scp[1].name, "white"); } oldfont = SelectObject(hdc, wc->font->font); @@ -1552,7 +1552,7 @@ int alc_rgb(wbp w, SysColor rgb) LOGPALETTE lp; if (palette) { for (i=0; i < numColors; i++) { - if (rgb == scp[i].c && scp[i].type == SHARED) break; + if (rgb == scp[i].c && scp[i].type == CSHARED) break; } if (i == numColors) { numColors++; @@ -1563,7 +1563,7 @@ int alc_rgb(wbp w, SysColor rgb) scp = realloc(scp, numColors * sizeof(struct wcolor)); if (scp == NULL) { numColors--; return Failed; } scp[numColors - 1].c = rgb; - scp[numColors - 1].type = SHARED; + scp[numColors - 1].type = CSHARED; sprintf(scp[numColors - 1].name, "%d,%d,%d", RED(rgb), GREEN(rgb), BLUE(rgb)); lp.palNumEntries = 1; @@ -2529,10 +2529,10 @@ HBITMAP loadimage(wbp w, char *filename, unsigned int *width, if ((scp = malloc(2 * sizeof (struct wcolor))) == NULL) return NULL; scp[0].c = RGB(0,0,0); - scp[0].type = SHARED; + scp[0].type = CSHARED; strcpy(scp[0].name, "black"); scp[1].c = RGB(255,255,255); - scp[1].type = SHARED; + scp[1].type = CSHARED; strcpy(scp[1].name, "white"); } else { @@ -2570,7 +2570,7 @@ char *get_mutable_name(wbp w, int mute_index) char *tmp; PALETTEENTRY pe; - if (-mute_index > numColors || scp[-mute_index].type != MUTABLE) { + if (-mute_index > numColors || scp[-mute_index].type != CMUTABLE) { return NULL; } @@ -2642,7 +2642,7 @@ int mutable_color(wbp w, dptr argv, int argc, int *retval) } scp[numColors-1].c = -(numColors-1); sprintf(scp[numColors-1].name, "%d:", -(numColors-1)); - scp[numColors-1].type = MUTABLE; + scp[numColors-1].type = CMUTABLE; if (ResizePalette(palette, numColors) == 0) { FREE_STDLOCALS(w); return Failed; diff --git a/src/runtime/rstruct.r b/src/runtime/rstruct.r index 22ab704..acf72f4 100644 --- a/src/runtime/rstruct.r +++ b/src/runtime/rstruct.r @@ -91,10 +91,6 @@ word i, j; Protect(lp2 = (struct b_list *) alclist(size), return Error); Protect(bp2 = (struct b_lelem *)alclstb(nslots,(word)0,size), return Error); lp2->listhead = lp2->listtail = (union block *) bp2; -#ifdef ListFix - bp2->listprev = bp2->listnext = (union block *) lp2; -#endif /* ListFix */ - cpslots(dp1, bp2->lslots, i, j); /* @@ -102,95 +98,9 @@ word i, j; */ dp2->dword = D_List; BlkLoc(*dp2) = (union block *) lp2; - EVValD(dp2, E_Lcreate); return Succeeded; } -#ifdef TableFix -/* - * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. - */ -int cpset(dp1, dp2, n) -dptr dp1, dp2; -word n; - { - int i = cphash(dp1, dp2, n, T_Set); - EVValD(dp2, E_Screate); - return i; - } - -int cptable(dp1, dp2, n) -dptr dp1, dp2; -word n; - { - int i = cphash(dp1, dp2, n, T_Table); - BlkLoc(*dp2)->table.defvalue = BlkLoc(*dp1)->table.defvalue; - EVValD(dp2, E_Tcreate); - return i; - } - -int cphash(dp1, dp2, n, tcode) -dptr dp1, dp2; -word n; -int tcode; - { - union block *src; - tended union block *dst; - tended struct b_slots *seg; - tended struct b_selem *ep, *prev; - struct b_selem *se; - register word slotnum; - register int i; - - /* - * Make a new set organized like dp1, with room for n elements. - */ - dst = hmake(tcode, BlkLoc(*dp1)->set.mask + 1, n); - if (dst == NULL) - return Error; - /* - * Copy the header and slot blocks. - */ - src = BlkLoc(*dp1); - dst->set.size = src->set.size; /* actual set size */ - dst->set.mask = src->set.mask; /* hash mask */ - for (i = 0; i < HSegs && src->set.hdir[i] != NULL; i++) - memcpy((char *)dst->set.hdir[i], (char *)src->set.hdir[i], - src->set.hdir[i]->blksize); - /* - * Work down the chain of element blocks in each bucket - * and create identical chains in new set. - */ - for (i = 0; i < HSegs && (seg = dst->set.hdir[i]) != NULL; i++) - for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { - prev = NULL; - for (ep = (struct b_selem *)seg->hslots[slotnum]; - ep != NULL && BlkType(ep) != T_Table; - ep = (struct b_selem *)ep->clink) { - if (tcode == T_Set) { - Protect(se = alcselem(&ep->setmem, ep->hashnum), return Error); - se->clink = ep->clink; - } - else { - Protect(se = (struct b_selem *)alctelem(), return Error); - *(struct b_telem *)se = *(struct b_telem *)ep; /* copy table entry */ - if (BlkType(se->clink) == T_Table) - se->clink = dst; - } - if (prev == NULL) - seg->hslots[slotnum] = (union block *)se; - else - prev->clink = (union block *)se; - prev = se; - } - } - dp2->dword = tcode | D_Typecode | F_Ptr; - BlkLoc(*dp2) = dst; - if (TooSparse(dst)) - hshrink(dst); - return Succeeded; - } -#else /* TableFix */ /* * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. */ @@ -243,10 +153,8 @@ word n; BlkLoc(*dp2) = dst; if (TooSparse(dst)) hshrink(dst); - Desc_EVValD(dst, E_Screate, D_Set); return Succeeded; } -#endif /* TableFix */ /* * hmake - make a hash structure (Set or Table) with a given number of slots. @@ -281,13 +189,6 @@ word nslots, nelem; for (; seg >= 0; seg--) { Protect(segp = alcsegment(segsize[seg]), return NULL); blk->set.hdir[seg] = segp; -#ifdef TableFix - if (tcode == T_Table) { - int j; - for (j = 0; j < segsize[seg]; j++) - segp->hslots[j] = blk; - } -#endif /* TableFix */ } blk->set.mask = nslots - 1; return blk; @@ -384,15 +285,9 @@ union block *ep; * has same hash value as the current one, in which case we defer it * by doing nothing now. */ -#ifdef TableFix - if (bp->table.mask != s->tmask && - (ep->selem.clink == NULL || BlkType(ep->telem.clink) == T_Table || - ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { -#else /* TableFix */ if (bp->table.mask != s->tmask && (ep->selem.clink == NULL || ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { -#endif /* TableFix */ /* * Yes, they did split. Make a note of the current state. */ @@ -414,12 +309,7 @@ union block *ep; * element, because it may have moved to a new segment. */ ep = bp->table.hdir[s->segnum]->hslots[s->slotnum]; -#ifdef TableFix - while (ep != NULL && BlkType(ep) != T_Table && - ep->telem.hashnum <= hn) -#else /* TableFix */ while (ep != NULL && ep->telem.hashnum <= hn) -#endif /* TableFix */ ep = ep->telem.clink; } @@ -429,22 +319,14 @@ union block *ep; * that have identical hash numbers. Find the next element in * the current hash chain. */ -#ifdef TableFix - if (ep != NULL && BlkType(ep) != T_Table) /* NULL on very first call */ -#else /* TableFix */ if (ep != NULL) /* already NULL on very first call */ -#endif /* TableFix */ ep = ep->telem.clink; /* next element in chain, if any */ } /* * If we don't yet have an element, search successive slots. */ -#ifdef TableFix - while (ep == NULL || BlkType(ep) == T_Table) { -#else /* TableFix */ while (ep == NULL) { -#endif /* TableFix */ /* * Move to the next slot and pick the first entry. */ @@ -470,12 +352,7 @@ union block *ep; * This chain was split from its parent while the parent was * being processed. Skip past elements already processed. */ -#ifdef TableFix - while (ep != NULL && BlkType(ep) != T_Table && - ep->telem.hashnum <= s->sghash[i]) -#else /* TableFix */ while (ep != NULL && ep->telem.hashnum <= s->sghash[i]) -#endif /* TableFix */ ep = ep->telem.clink; } } @@ -484,9 +361,6 @@ union block *ep; /* * Return the element. */ -#ifdef TableFix - if (ep && BlkType(ep) == T_Table) ep = NULL; -#endif /* TableFix */ return ep; } @@ -508,25 +382,12 @@ union block *bp; return; /* can't split further */ newslots = ps->mask + 1; Protect(newseg = alcsegment(newslots), return); -#ifdef TableFix - if (BlkType(bp) == T_Table) { - int j; - for(j=0; j<newslots; j++) newseg->hslots[j] = bp; - } -#endif /* TableFix */ - curslot = newseg->hslots; for (segnum = 0; (seg = ps->hdir[segnum]) != NULL; segnum++) for (slotnum = 0; slotnum < segsize[segnum]; slotnum++) { tp0 = &seg->hslots[slotnum]; /* ptr to tail of old slot */ tp1 = curslot++; /* ptr to tail of new slot */ -#ifdef TableFix - for (ep = *tp0; - ep != NULL && BlkType(ep) != T_Table; - ep = ep->selem.clink) { -#else /* TableFix */ for (ep = *tp0; ep != NULL; ep = ep->selem.clink) { -#endif /* TableFix */ if ((ep->selem.hashnum & newslots) == 0) { *tp0 = ep; /* element does not move */ tp0 = &ep->selem.clink; @@ -536,14 +397,7 @@ union block *bp; tp1 = &ep->selem.clink; } } -#ifdef TableFix - if ( BlkType(bp) == T_Table ) - *tp0 = *tp1 = bp; - else - *tp0 = *tp1 = NULL; -#else /* TableFix */ *tp0 = *tp1 = NULL; -#endif /* TableFix */ } ps->hdir[segnum] = newseg; ps->mask = (ps->mask << 1) | 1; @@ -578,12 +432,7 @@ union block *bp; tp = &seg->hslots[slotnum]; /* tail pointer */ ep0 = seg->hslots[slotnum]; /* lower slot entry pointer */ ep1 = *uppslot++; /* upper slot entry pointer */ -#ifdef TableFix - while (ep0 != NULL && BlkType(ep0) != T_Table && - ep1 != NULL && BlkType(ep1) != T_Table) -#else /* TableFix */ while (ep0 != NULL && ep1 != NULL) -#endif /* TableFix */ if (ep0->selem.hashnum < ep1->selem.hashnum) { *tp = ep0; tp = &ep0->selem.clink; @@ -594,20 +443,12 @@ union block *bp; tp = &ep1->selem.clink; ep1 = ep1->selem.clink; } -#ifdef TableFix - while (ep0 != NULL && BlkType(ep0) != T_Table) { -#else /* TableFix */ while (ep0 != NULL) { -#endif /* TableFix */ *tp = ep0; tp = &ep0->selem.clink; ep0 = ep0->selem.clink; } -#ifdef TableFix - while (ep1 != NULL && BlkType(ep1) != T_Table) { -#else /* TableFix */ while (ep1 != NULL) { -#endif /* TableFix */ *tp = ep1; tp = &ep1->selem.clink; ep1 = ep1->selem.clink; @@ -640,11 +481,7 @@ int *res; /* pointer to integer result flag */ * Look for x in the hash chain. */ *res = 0; -#ifdef TableFix - while ((pe = (struct b_selem *)*lp) != NULL && BlkType(pe) != T_Table) { -#else /* TableFix */ while ((pe = (struct b_selem *)*lp) != NULL) { -#endif /* TableFix */ eh = pe->hashnum; if (eh > hn) /* too far - it isn't there */ return lp; diff --git a/src/runtime/rsys.r b/src/runtime/rsys.r index f4bdfc1..83f6380 100644 --- a/src/runtime/rsys.r +++ b/src/runtime/rsys.r @@ -126,16 +126,11 @@ dptr d; int idelay(n) int n; { - #if MSWIN - Sleep(n); - return Succeeded; - #else /* MSWIN */ - struct timeval t; - t.tv_sec = n / 1000; - t.tv_usec = (n % 1000) * 1000; - select(1, NULL, NULL, NULL, &t); - return Succeeded; - #endif /* MSWIN */ + struct timeval t; + t.tv_sec = n / 1000; + t.tv_usec = (n % 1000) * 1000; + select(1, NULL, NULL, NULL, &t); + return Succeeded; } #ifdef KeyboardFncs diff --git a/src/runtime/rwindow.r b/src/runtime/rwindow.r index 752baa2..0ad4ddc 100644 --- a/src/runtime/rwindow.r +++ b/src/runtime/rwindow.r @@ -10,7 +10,6 @@ static int sicmp (siptr sip1, siptr sip2); int canvas_serial, context_serial; -#ifndef MultiThread struct descrip amperX = {D_Integer}; struct descrip amperY = {D_Integer}; struct descrip amperCol = {D_Integer}; @@ -19,8 +18,6 @@ struct descrip amperInterval = {D_Integer}; struct descrip lastEventWin = {D_Null}; int lastEvFWidth = 0, lastEvLeading = 0, lastEvAscent = 0; uword xmod_control, xmod_shift, xmod_meta; -#endif /* MultiThread */ - /* * subscript the already-processed-events "queue" to index i. diff --git a/src/runtime/rxrsc.ri b/src/runtime/rxrsc.ri index c99edeb..199468c 100644 --- a/src/runtime/rxrsc.ri +++ b/src/runtime/rxrsc.ri @@ -16,7 +16,7 @@ int fontcmp(char *font1, char *font2, int size, int flags); /* check for color match */ #define CMATCH(cp, rr, gg, bb) \ ((cp)->r == (rr) && (cp)->g == (gg) && (cp->b) == (bb) && \ - (cp)->type == SHARED && (cp)->refcount > 0) + (cp)->type == CSHARED && (cp)->refcount > 0) /* * Allocate a color given linear r, g, b. Colors are shared on a @@ -122,7 +122,7 @@ int is_iconcolor; cp->g = g; cp->b = b; cp->c = color.pixel; - cp->type = SHARED; + cp->type = CSHARED; /* * Remember in window color list, too, if not TrueColor visual. */ @@ -234,7 +234,7 @@ wbp w1, w2; for (i1 = 0; i1 < ws1->numColors; i1++) { j = ws1->theColors[i1]; - if (wd->colrptrs[j]->refcount > 0 && wd->colrptrs[j]->type != MUTABLE) { + if (wd->colrptrs[j]->refcount > 0 && wd->colrptrs[j]->type != CMUTABLE) { for (i2 = 0; i2 < ws2->numColors; i2++) { if (j == ws2->theColors[i2]) break; @@ -315,33 +315,11 @@ int extent; */ if (((extent==0) && (wd->colrptrs[j] == w->context->fg)) || ((extent==0) && (wd->colrptrs[j] == w->context->bg)) || - (wd->colrptrs[j]->type == MUTABLE)) { + (wd->colrptrs[j]->type == CMUTABLE)) { theColors[numSaved++] = j; continue; } -#ifdef FreeColorFix - /* - * don't free ANY context's fg or bg - */ - { - wcp wc; int numhits = 0; - for(wc=wcntxts; wc; wc=wc->next) { - if ((wc->fg == wd->colrptrs[j]) || - (wc->bg == wd->colrptrs[j])) { - if (numhits == 0) - theColors[numSaved++] = j; - numhits++; - } - } - if (numhits) { - if (numhits > wd->colrptrs[j]->refcount) - wd->colrptrs[j]->refcount = numhits; - continue; - } - } -#endif /* FreeColorFix */ - if (--(wd->colrptrs[j]->refcount) == 0) { toFree[freed++] = wd->colrptrs[j]->c; } @@ -428,7 +406,7 @@ char *s; cp = wd->colrptrs[0]; strcpy(cp->name,"black"); - cp->type = SHARED; + cp->type = CSHARED; cp->r = cp->g = cp->b = 0; color.red = color.green = color.blue = 0; if (XAllocColor(wd->display, wd->cmap, &color)) @@ -438,7 +416,7 @@ char *s; cp = wd->colrptrs[1]; strcpy(cp->name,"white"); - cp->type = SHARED; + cp->type = CSHARED; cp->r = cp->g = cp->b = 65535; color.red = color.green = color.blue = 65535; if (XAllocColor(wd->display, wd->cmap, &color)) @@ -685,7 +663,7 @@ int size, flags; */ p = xlfd_field(fontlist[champ], XLFD_Size); if (p[0] == '0' && p[1] == '-') - sprintf(fontspec, "%.*s%d%s", p - fontlist[champ], + sprintf(fontspec, "%.*s%d%s", (int) (p - fontlist[champ]), fontlist[champ], bestsize, p + 1); else strcpy(fontspec, fontlist[champ]); diff --git a/src/runtime/rxwin.ri b/src/runtime/rxwin.ri index c2dc48c..3db8086 100644 --- a/src/runtime/rxwin.ri +++ b/src/runtime/rxwin.ri @@ -1140,22 +1140,7 @@ char *s; } else { if (ws->iconic != IconicState) { -#ifdef Iconify - if (ws->win == (Window) NULL) { - wmap(w); - } - XIconifyWindow(ws->display->display, ws->win, ws->display->screen); - XSync(stddpy, False); - while (ws->iconic != IconicState) - if ((hm = handle_misc(wd, NULL)) < 1) { - if (hm == -1) return Error; - else if (hm == 0) { - return Failed; - } - } -#else /* Iconify */ return Failed; -#endif /* Iconify */ } } } @@ -1265,11 +1250,7 @@ char *s; } else { if (ws->iconic != IconicState) { -#ifdef Iconify - XIconifyWindow(ws->display->display, ws->win, ws->display->screen); -#else /* Iconify */ return Failed; -#endif /* Iconify */ } } } @@ -1509,7 +1490,7 @@ int fg; return setfgrgb(w, r * 257, g * 257, b * 257); } for (i = 2; i < wd->numColors; i++) - if (wd->colrptrs[i]->type == MUTABLE && wd->colrptrs[i]->c == -fg - 1) + if (wd->colrptrs[i]->type == CMUTABLE && wd->colrptrs[i]->c == -fg - 1) break; if (i == wd->numColors) return Failed; wc->fg = wd->colrptrs[i]; @@ -1562,7 +1543,7 @@ int bg; return setbgrgb(w, r * 257, g * 257, b * 257); } for (i = 2; i < wd->numColors; i++) - if (wd->colrptrs[i]->type == MUTABLE && wd->colrptrs[i]->c == -bg - 1) + if (wd->colrptrs[i]->type == CMUTABLE && wd->colrptrs[i]->c == -bg - 1) break; if (i == wd->numColors) return Failed; wc->bg = wd->colrptrs[i]; @@ -2287,7 +2268,7 @@ int *retval; i = alc_centry(wd); if (i == 0) return Failed; - wd->colrptrs[i]->type = MUTABLE; + wd->colrptrs[i]->type = CMUTABLE; wd->colrptrs[i]->c = pixels[0]; /* save color index as "name", followed by a null string for value */ @@ -2351,7 +2332,7 @@ int mute_index; d = dp->display; for (i = 2; i < dp->numColors; i++) - if (dp->colrptrs[i]->type == MUTABLE + if (dp->colrptrs[i]->type == CMUTABLE && dp->colrptrs[i]->c == - mute_index - 1) break; if (i == dp->numColors) @@ -2390,7 +2371,7 @@ int mute_index; d = dp->display; for (i = 2; i < dp->numColors; i++) - if (dp->colrptrs[i]->type == MUTABLE + if (dp->colrptrs[i]->type == CMUTABLE && dp->colrptrs[i]->c == - mute_index - 1) break; if (i != dp->numColors) @@ -2416,7 +2397,7 @@ char *s; for (i = 2; i < dp->numColors; i++) if (dp->colrptrs[i]->r == color.red && dp->colrptrs[i]->g == color.green - && dp->colrptrs[i]->b == color.blue && dp->colrptrs[i]->type != MUTABLE) + && dp->colrptrs[i]->b == color.blue && dp->colrptrs[i]->type != CMUTABLE) break; if (i != dp->numColors) free_xcolor(w, dp->colrptrs[i]->c); @@ -2794,7 +2775,7 @@ struct imgmem *imem; for (cpp = wd->colrptrs ; cpp < wd->colrptrs + wd->numColors; cpp++) { if ((*cpp)->c == c) { - if ((*cpp)->type == MUTABLE) + if ((*cpp)->type == CMUTABLE) *rv = -c - 1; else { *rv = 1; |